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 or
   8 perl, we test against 2 (currently) core packages which have lots of
   9 XS functions; B and Digest::MD5.  They're listed in %$testpkgs, along
  10 with a list of functions that are (or are not) XS.  For brevity, you
  11 can specify the shorter list; if they're non-xs routines, start list
  12 with a '!'.  Data::Dumper is also tested, partly to prove the non-!
  13 usage.
  14
  15 We demand-load each package, scan its stash for function names, and
  16 mark them as XS/not-XS according to the list given for each package.
  17 Then we test B::Concise's report on each.
  18
  19 If module-names are given as args, those packages are run through the
  20 test harness; this is handy for collecting further items to test, and
  21 may be useful otherwise (ie just to see).
  22
  23 If -a option is given, we use Module::CoreList to run all packages,
  24 which gives some interesting results.
  25
  26 -v and -V trigger 2 levels of verbosity.
  27
  28 =cut
  29
  30 BEGIN {
  31     if ($ENV{PERL_CORE}) {
  32         chdir('t') if -d 't';
  33         @INC = ('.', '../lib');
  34     } else {
  35         unshift @INC, 't';
  36         push @INC, "../../t";
  37     }
  38     require Config;
  39     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
  40         print "1..0 # Skip -- Perl configured without B module\n";
  41         exit 0;
  42     }
  43 }
  44
  45 use Getopt::Std;
  46 use Carp;
  47 use Test::More tests => ( 1 * !!$Config::Config{useithreads}
  48                           + 2 * ($] > 5.009)
  49                           + 272);
  50
  51 require_ok("B::Concise");
  52
  53 my $testpkgs = {
  54
  55     Digest::MD5 => [qw/ ! import /],
  56
  57     B => [qw/ ! class clearsym compile_stats debug objsym parents
  58               peekop savesym timing_info walkoptree_exec
  59               walkoptree_slow walksymtable /],
  60
  61     Data::Dumper => [qw/ bootstrap Dumpxs /],
  62 };
  63
  64 ############
  65
  66 B::Concise::compile('-nobanner');       # set a silent default
  67 getopts('vaV', \my %opts) or
  68     die <<EODIE;
  69
  70 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
  71     tests ability to discern XS funcs using Digest::MD5 package
  72     -v  : runs verbosely
  73     -V  : more verbosity
  74     -a  : runs all modules in CoreList
  75     <args> : additional modules are loaded and tested
  76         (will report failures, since no XS funcs are known aprior)
  77
  78 EODIE
  79     ;
  80
  81 if (%opts) {
  82     require Data::Dumper;
  83     Data::Dumper->import('Dumper');
  84     $Data::Dumper::Sortkeys = 1;
  85 }
  86 my @argpkgs = @ARGV;
  87
  88 foreach $pkg (sort(keys %$testpkgs), @argpkgs) {
  89     test_pkg($pkg, $testpkgs->{$pkg});
  90 }
  91
  92 corecheck() if $opts{a};
  93
  94 ############
  95
  96 sub test_pkg {
  97     my ($pkg_name, $xslist) = @_;
  98     require_ok($pkg_name);
  99
 100     unless (ref $xslist eq 'ARRAY') {
 101         warn "no XS/non-XS function list given, assuming empty XS list";
 102         $xslist = [''];
 103     }
 104
 105     my $assumeXS = 0;   # assume list enumerates XS funcs, not perl ones
 106     $assumeXS = 1       if $xslist->[0] eq '!';
 107
 108     # build %stash: keys are func-names, vals: 1 if XS, 0 if not
 109     my (%stash) = map
 110         ( ($_ => $assumeXS)
 111           => ( grep exists &{"$pkg_name\::$_"}  # grab CODE symbols
 112                => grep !/__ANON__/              # but not anon subs
 113                => keys %{$pkg_name.'::'}        # from symbol table
 114                ));
 115
 116     # now invert according to supplied list
 117     $stash{$_} = int ! $assumeXS foreach @$xslist;
 118
 119     # and cleanup cruft (easier than preventing)
 120     delete @stash{'!',''};
 121
 122     if (%opts) {
 123         diag("xslist: " => Dumper($xslist));
 124         diag("$pkg_name stash: " => Dumper(\%stash));
 125     }
 126
 127     foreach $func_name (reverse sort keys %stash) {
 128         $DB::single = 1 if $func_name =~ /AUTOLOAD/;
 129         checkXS("${pkg_name}::$func_name", $stash{$func_name});
 130     }
 131 }
 132
 133 sub checkXS {
 134     my ($func_name, $wantXS) = @_;
 135
 136     my ($buf, $err) = render($func_name);
 137     if ($wantXS) {
 138         like($buf, qr/\Q$func_name is XS code/,
 139              "XS code:\t $func_name");
 140     } else {
 141         unlike($buf, qr/\Q$func_name is XS code/,
 142                "perl code:\t $func_name");
 143     }
 144     #returns like or unlike, whichever was called
 145 }
 146
 147 sub render {
 148     my ($func_name) = @_;
 149
 150     B::Concise::reset_sequence();
 151     B::Concise::walk_output(\my $buf);
 152
 153     my $walker = B::Concise::compile($func_name);
 154     eval { $walker->() };
 155     diag("err: $@ $buf") if $@;
 156     diag("verbose: $buf") if $opts{V};
 157
 158     return ($buf, $@);
 159 }
 160
 161 sub corecheck {
 162     eval { require Module::CoreList };
 163     if ($@) {
 164         warn "Module::CoreList not available on $]\n";
 165         return;
 166     }
 167     my $mods = $Module::CoreList::version{'5.009001'};  # $]}; # undef ??
 168     print Dumper($mods);
 169
 170     foreach my $pkgnm (sort keys %$mods) {
 171         test_pkg($pkgnm);
 172     }
 173 }
 174
 175 __END__