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 'no_plan';
 119
 120 require_ok("B::Concise");
 121
 122 my %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
 130 my $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_LOCKED 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                  },
 178
 179     POSIX => { dflt => 'constant',                      # all but 252/589
 180                skip => [qw/ _POSIX_JOB_CONTROL /,       # platform varying
 181                         # Might be XS or imported from Fcntl, depending on your
 182                         # perl version:
 183                         qw / S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG /,
 184                         # Might be XS or AUTOLOADed, depending on your perl
 185                         # version:
 186                         qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
 187                             WSTOPSIG WTERMSIG/,
 188                        'int_macro_int', # Removed in POSIX 1.16
 189                        ],
 190                perl => [qw/ import croak AUTOLOAD /],
 191
 192                XS => [qw/ write wctomb wcstombs uname tzset tzname
 193                       ttyname tmpnam times tcsetpgrp tcsendbreak
 194                       tcgetpgrp tcflush tcflow tcdrain tanh tan
 195                       sysconf strxfrm strtoul strtol strtod
 196                       strftime strcoll sinh sigsuspend sigprocmask
 197                       sigpending sigaction setuid setsid setpgid
 198                       setlocale setgid read pipe pause pathconf
 199                       open nice modf mktime mkfifo mbtowc mbstowcs
 200                       mblen lseek log10 localeconv ldexp lchown
 201                       isxdigit isupper isspace ispunct isprint
 202                       islower isgraph isdigit iscntrl isalpha
 203                       isalnum getcwd frexp fpathconf
 204                       fmod floor dup2 dup difftime cuserid ctime
 205                       ctermid cosh constant close clock ceil
 206                       bootstrap atan asin asctime acos access abort
 207                       _exit
 208                       /],
 209                },
 210
 211     IO::Socket => { dflt => 'constant',         # 157/190
 212
 213                     perl => [qw/ timeout socktype sockopt sockname
 214                              socketpair socket sockdomain sockaddr_un
 215                              sockaddr_in shutdown setsockopt send
 216                              register_domain recv protocol peername
 217                              new listen import getsockopt croak
 218                              connected connect configure confess close
 219                              carp bind atmark accept
 220                              /, $] > 5.009 ? ('blocking') : () ],
 221
 222                     XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
 223                            sockatmark sockaddr_family pack_sockaddr_un
 224                            pack_sockaddr_in inet_ntoa inet_aton
 225                            /],
 226                 },
 227 };
 228
 229 ############
 230
 231 B::Concise::compile('-nobanner');       # set a silent default
 232 getopts('vaVcr:', \my %opts) or
 233     die <<EODIE;
 234
 235 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
 236     tests ability to discern XS funcs using Digest::MD5 package
 237     -v  : runs verbosely
 238     -V  : more verbosity
 239     -a  : runs all modules in CoreList
 240     -c  : writes test corrections as a Data::Dumper expression
 241     -r <file>   : reads file of tests, as written by -c
 242     <args>      : additional modules are loaded and tested
 243         (will report failures, since no XS funcs are known apriori)
 244
 245 EODIE
 246     ;
 247
 248 if (%opts) {
 249     require Data::Dumper;
 250     Data::Dumper->import('Dumper');
 251     $Data::Dumper::Sortkeys = 1;
 252 }
 253 my @argpkgs = @ARGV;
 254 my %report;
 255
 256 if ($opts{r}) {
 257     my $refpkgs = require "$opts{r}";
 258     $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
 259 }
 260
 261 unless ($opts{a}) {
 262     unless (@argpkgs) {
 263         foreach $pkg (sort keys %$testpkgs) {
 264             test_pkg($pkg, $testpkgs->{$pkg});
 265         }
 266     } else {
 267         foreach $pkg (@argpkgs) {
 268             test_pkg($pkg, $testpkgs->{$pkg});
 269         }
 270     }
 271 } else {
 272     corecheck();
 273 }
 274 ############
 275
 276 sub test_pkg {
 277     my ($pkg, $fntypes) = @_;
 278     require_ok($pkg);
 279
 280     # build %stash: keys are func-names, vals filled in below
 281     my (%stash) = map
 282         ( ($_ => 0)
 283           => ( grep exists &{"$pkg\::$_"}       # grab CODE symbols
 284                => grep !/__ANON__/              # but not anon subs
 285                => keys %{$pkg.'::'}             # from symbol table
 286                ));
 287
 288     for my $type (keys %matchers) {
 289         foreach my $fn (@{$fntypes->{$type}}) {
 290             carp "$fn can only be one of $type, $stash{$fn}\n"
 291                 if $stash{$fn};
 292             $stash{$fn} = $type;
 293         }
 294     }
 295     # set default type for un-named functions
 296     my $dflt = $fntypes->{dflt} || 'perl';
 297     for my $k (keys %stash) {
 298         $stash{$k} = $dflt unless $stash{$k};
 299     }
 300     $stash{$_} = 'skip' foreach @{$fntypes->{skip}};
 301
 302     if ($opts{v}) {
 303         diag("fntypes: " => Dumper($fntypes));
 304         diag("$pkg stash: " => Dumper(\%stash));
 305     }
 306     foreach my $fn (reverse sort keys %stash) {
 307         next if $stash{$fn} eq 'skip';
 308         my $res = checkXS("${pkg}::$fn", $stash{$fn});
 309         if ($res ne '1') {
 310             push @{$report{$pkg}{$res}}, $fn;
 311         }
 312     }
 313 }
 314
 315 sub checkXS {
 316     my ($func_name, $want) = @_;
 317
 318     croak "unknown type $want: $func_name\n"
 319         unless defined $matchers{$want};
 320
 321     my ($buf, $err) = render($func_name);
 322     my $res = like($buf, $matchers{$want}, "$want sub:\t $func_name");
 323
 324     unless ($res) {
 325         # test failed. return type that would give success
 326         for my $m (keys %matchers) {
 327             return $m if $buf =~ $matchers{$m};
 328         }
 329     }
 330     $res;
 331 }
 332
 333 sub render {
 334     my ($func_name) = @_;
 335
 336     B::Concise::reset_sequence();
 337     B::Concise::walk_output(\my $buf);
 338
 339     my $walker = B::Concise::compile($func_name);
 340     eval { $walker->() };
 341     diag("err: $@ $buf") if $@;
 342     diag("verbose: $buf") if $opts{V};
 343
 344     return ($buf, $@);
 345 }
 346
 347 sub corecheck {
 348     eval { require Module::CoreList };
 349     if ($@) {
 350         warn "Module::CoreList not available on $]\n";
 351         return;
 352     }
 353     my $mods = $Module::CoreList::version{'5.009002'};
 354     $mods = [ sort keys %$mods ];
 355     print Dumper($mods);
 356
 357     foreach my $pkgnm (@$mods) {
 358         test_pkg($pkgnm);
 359     }
 360 }
 361
 362 END {
 363     if ($opts{c}) {
 364         $Data::Dumper::Indent = 1;
 365         print "Corrections: ", Dumper(\%report);
 366
 367         foreach my $pkg (sort keys %report) {
 368             for my $type (keys %matchers) {
 369                 print "$pkg: $type: @{$report{$pkg}{$type}}\n"
 370                     if @{$report{$pkg}{$type}};
 371             }
 372         }
 373     }
 374 }
 375
 376 __END__