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