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 =head1 OPTIONS AND ARGUMENTS
  20
  21 C<-v> and C<-V> trigger 2 levels of verbosity.
  22
  23 C<-a> uses Module::CoreList to run all core packages through the test, which
  24 gives some interesting results.
  25
  26 C<-c> causes the expected XS/non-XS results to be marked with
  27 corrections, which are then reported at program END, in a
  28 Data::Dumper statement
  29
  30 C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
  31 results accordingly.  The file is 'required', so @INC settings apply.
  32
  33 If module-names are given as args, those packages are run through the
  34 test harness; this is handy for collecting further items to test, and
  35 may be useful otherwise (ie just to see).
  36
  37 =head1 EXAMPLES
  38
  39 All following examples avoid using PERL_CORE=1, since that changes @INC
  40
  41 =over 4
  42
  43 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
  44
  45 Tests Storable.pm for XS/non-XS routines, writes findings (along with
  46 test results) to stdout.  You could edit results to produce a test
  47 file, as in next example
  48
  49 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
  50
  51 Loads file, and uses it to set expectations, and run tests
  52
  53 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2
  54
  55 Gets module list from Module::Corelist, and runs them all through the
  56 test.  Since -c is used, this generates corrections, which are saved
  57 in a file, which is edited down to produce ../all-xs
  58
  59 =item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2
  60
  61 This runs the tests specified in the file created in previous example.
  62 -c is used again, and stdout verifies that all the expected results
  63 given by -r ../all-xs are now seen.
  64
  65 Looking at ../foo2, you'll see 34 occurrences of the following error:
  66
  67 # err: Can't use an undefined value as a SCALAR reference at
  68 # lib/B/Concise.pm line 634, <DATA> line 1.
  69
  70 =back
  71
  72 =cut
  73
  74 BEGIN {
  75     if ($ENV{PERL_CORE}) {
  76         chdir('t') if -d 't';
  77         @INC = ('.', '../lib');
  78     } else {
  79         unshift @INC, 't';
  80         push @INC, "../../t";
  81     }
  82     require Config;
  83     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
  84         print "1..0 # Skip -- Perl configured without B module\n";
  85         exit 0;
  86     }
  87 }
  88
  89 use Getopt::Std;
  90 use Carp;
  91 use Test::More tests => ( 1 * !!$Config::Config{useithreads}
  92                           + 3 * ($] > 5.009)
  93                           + 777 );
  94
  95 require_ok("B::Concise");
  96
  97 my $testpkgs = {
  98
  99     Digest::MD5 => [qw/ ! import /],
 100
 101     B => [qw/ ! class clearsym compile_stats debug objsym parents
 102               peekop savesym timing_info walkoptree_exec
 103               walkoptree_slow walksymtable /],
 104
 105     Data::Dumper => [qw/ bootstrap Dumpxs /],
 106
 107     B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
 108                    CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
 109                    OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
 110                    OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
 111                    OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
 112                    OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
 113                    OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
 114                    OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
 115                    OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
 116                    OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
 117                    PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
 118                    PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
 119                    POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
 120                    SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
 121                    main_root main_start opnumber perlstring
 122                    svref_2object /],
 123
 124 };
 125
 126 ############
 127
 128 B::Concise::compile('-nobanner');       # set a silent default
 129 getopts('vaVcr:', \my %opts) or
 130     die <<EODIE;
 131
 132 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
 133     tests ability to discern XS funcs using Digest::MD5 package
 134     -v  : runs verbosely
 135     -V  : more verbosity
 136     -a  : runs all modules in CoreList
 137     -c  : writes test corrections as a Data::Dumper expression
 138     -r <file>   : reads file of tests, as written by -c
 139     <args>      : additional modules are loaded and tested
 140         (will report failures, since no XS funcs are known aprior)
 141
 142 EODIE
 143     ;
 144
 145 if (%opts) {
 146     require Data::Dumper;
 147     Data::Dumper->import('Dumper');
 148     $Data::Dumper::Sortkeys = 1;
 149 }
 150 my @argpkgs = @ARGV;
 151 my %report;
 152
 153 if ($opts{r}) {
 154     my $refpkgs = require "$opts{r}";
 155     $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
 156 }
 157
 158 unless ($opts{a}) {
 159     unless (@argpkgs) {
 160         foreach $pkg (sort keys %$testpkgs) {
 161             test_pkg($pkg, $testpkgs->{$pkg});
 162         }
 163     } else {
 164         foreach $pkg (@argpkgs) {
 165             test_pkg($pkg, $testpkgs->{$pkg});
 166         }
 167     }
 168 } else {
 169     corecheck();
 170 }
 171 ############
 172
 173 sub test_pkg {
 174     my ($pkg_name, $xslist) = @_;
 175     require_ok($pkg_name);
 176
 177     unless (ref $xslist eq 'ARRAY') {
 178         warn "no XS/non-XS function list given, assuming empty XS list";
 179         $xslist = [''];
 180     }
 181
 182     my $assumeXS = 0;   # assume list enumerates XS funcs, not perl ones
 183     $assumeXS = 1       if $xslist->[0] and $xslist->[0] eq '!';
 184
 185     # build %stash: keys are func-names, vals: 1 if XS, 0 if not
 186     my (%stash) = map
 187         ( ($_ => $assumeXS)
 188           => ( grep exists &{"$pkg_name\::$_"}  # grab CODE symbols
 189                => grep !/__ANON__/              # but not anon subs
 190                => keys %{$pkg_name.'::'}        # from symbol table
 191                ));
 192
 193     # now invert according to supplied list
 194     $stash{$_} = int ! $assumeXS foreach @$xslist;
 195
 196     # and cleanup cruft (easier than preventing)
 197     delete @stash{'!',''};
 198
 199     if ($opts{v}) {
 200         diag("xslist: " => Dumper($xslist));
 201         diag("$pkg_name stash: " => Dumper(\%stash));
 202     }
 203     my $err;
 204     foreach $func_name (reverse sort keys %stash) {
 205         my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
 206         if (!$res) {
 207             $stash{$func_name} ^= 1;
 208             print "$func_name ";
 209             $err++;
 210         }
 211     }
 212     $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
 213 }
 214
 215 sub checkXS {
 216     my ($func_name, $wantXS) = @_;
 217
 218     my ($buf, $err) = render($func_name);
 219     if ($wantXS) {
 220         like($buf, qr/\Q$func_name is XS code/,
 221              "XS code:\t $func_name");
 222     } else {
 223         unlike($buf, qr/\Q$func_name is XS code/,
 224                "perl code:\t $func_name");
 225     }
 226     #returns like or unlike, whichever was called
 227 }
 228
 229 sub render {
 230     my ($func_name) = @_;
 231
 232     B::Concise::reset_sequence();
 233     B::Concise::walk_output(\my $buf);
 234
 235     my $walker = B::Concise::compile($func_name);
 236     eval { $walker->() };
 237     diag("err: $@ $buf") if $@;
 238     diag("verbose: $buf") if $opts{V};
 239
 240     return ($buf, $@);
 241 }
 242
 243 sub corecheck {
 244
 245     eval { require Module::CoreList };
 246     if ($@) {
 247         warn "Module::CoreList not available on $]\n";
 248         return;
 249     }
 250     my $mods = $Module::CoreList::version{'5.009002'};
 251     $mods = [ sort keys %$mods ];
 252     print Dumper($mods);
 253
 254     foreach my $pkgnm (@$mods) {
 255         test_pkg($pkgnm);
 256     }
 257 }
 258
 259 END {
 260     if ($opts{c}) {
 261         # print "Corrections: ", Dumper(\%report);
 262         print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
 263         print "\$VAR1 = {\n";
 264
 265         foreach my $pkg (sort keys %report) {
 266             my (@xs, @perl);
 267             my $stash = $report{$pkg};
 268
 269             @xs   = sort grep $stash->{$_} == 1, keys %$stash;
 270             @perl = sort grep $stash->{$_} == 0, keys %$stash;
 271
 272             my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
 273             print "\t$pkg => [qw/ @list /],\n";
 274         }
 275         print "};\n";
 276     }
 277 }
 278
 279 __END__