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     unless ($Config::Config{useperlio}) {
  88         print "1..0 # Skip -- Perl configured without perlio\n";
  89         exit 0;
  90     }
  91 }
  92
  93 use Getopt::Std;
  94 use Carp;
  95 use Test::More tests => ( 1 * !!$Config::Config{useithreads}
  96                           + 3 * ($] > 5.009)
  97                           + 14 * ($] >= 5.009003)
  98                           + 777 );
  99
 100 require_ok("B::Concise");
 101
 102 my $testpkgs = {
 103
 104     Digest::MD5 => [qw/ ! import /],
 105
 106     B => [qw/ ! class clearsym compile_stats debug objsym parents
 107               peekop savesym timing_info walkoptree_exec
 108               walkoptree_slow walksymtable /],
 109
 110     Data::Dumper => [qw/ bootstrap Dumpxs /],
 111
 112     B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
 113                    CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
 114                    OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
 115                    OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
 116                    OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
 117                    OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
 118                    OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
 119                    OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
 120                    OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
 121                    OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
 122                    PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
 123                    PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
 124                    POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
 125                    SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
 126                    main_root main_start opnumber perlstring
 127                    svref_2object /],
 128
 129 };
 130
 131 ############
 132
 133 B::Concise::compile('-nobanner');       # set a silent default
 134 getopts('vaVcr:', \my %opts) or
 135     die <<EODIE;
 136
 137 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
 138     tests ability to discern XS funcs using Digest::MD5 package
 139     -v  : runs verbosely
 140     -V  : more verbosity
 141     -a  : runs all modules in CoreList
 142     -c  : writes test corrections as a Data::Dumper expression
 143     -r <file>   : reads file of tests, as written by -c
 144     <args>      : additional modules are loaded and tested
 145         (will report failures, since no XS funcs are known aprior)
 146
 147 EODIE
 148     ;
 149
 150 if (%opts) {
 151     require Data::Dumper;
 152     Data::Dumper->import('Dumper');
 153     $Data::Dumper::Sortkeys = 1;
 154 }
 155 my @argpkgs = @ARGV;
 156 my %report;
 157
 158 if ($opts{r}) {
 159     my $refpkgs = require "$opts{r}";
 160     $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
 161 }
 162
 163 unless ($opts{a}) {
 164     unless (@argpkgs) {
 165         foreach $pkg (sort keys %$testpkgs) {
 166             test_pkg($pkg, $testpkgs->{$pkg});
 167         }
 168     } else {
 169         foreach $pkg (@argpkgs) {
 170             test_pkg($pkg, $testpkgs->{$pkg});
 171         }
 172     }
 173 } else {
 174     corecheck();
 175 }
 176 ############
 177
 178 sub test_pkg {
 179     my ($pkg_name, $xslist) = @_;
 180     require_ok($pkg_name);
 181
 182     unless (ref $xslist eq 'ARRAY') {
 183         warn "no XS/non-XS function list given, assuming empty XS list";
 184         $xslist = [''];
 185     }
 186
 187     my $assumeXS = 0;   # assume list enumerates XS funcs, not perl ones
 188     $assumeXS = 1       if $xslist->[0] and $xslist->[0] eq '!';
 189
 190     # build %stash: keys are func-names, vals: 1 if XS, 0 if not
 191     my (%stash) = map
 192         ( ($_ => $assumeXS)
 193           => ( grep exists &{"$pkg_name\::$_"}  # grab CODE symbols
 194                => grep !/__ANON__/              # but not anon subs
 195                => keys %{$pkg_name.'::'}        # from symbol table
 196                ));
 197
 198     # now invert according to supplied list
 199     $stash{$_} = int ! $assumeXS foreach @$xslist;
 200
 201     # and cleanup cruft (easier than preventing)
 202     delete @stash{'!',''};
 203
 204     if ($opts{v}) {
 205         diag("xslist: " => Dumper($xslist));
 206         diag("$pkg_name stash: " => Dumper(\%stash));
 207     }
 208     my $err;
 209     foreach $func_name (reverse sort keys %stash) {
 210         my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
 211         if (!$res) {
 212             $stash{$func_name} ^= 1;
 213             print "$func_name ";
 214             $err++;
 215         }
 216     }
 217     $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
 218 }
 219
 220 sub checkXS {
 221     my ($func_name, $wantXS) = @_;
 222
 223     my ($buf, $err) = render($func_name);
 224     if ($wantXS) {
 225         like($buf, qr/\Q$func_name is XS code/,
 226              "XS code:\t $func_name");
 227     } else {
 228         unlike($buf, qr/\Q$func_name is XS code/,
 229                "perl code:\t $func_name");
 230     }
 231     #returns like or unlike, whichever was called
 232 }
 233
 234 sub render {
 235     my ($func_name) = @_;
 236
 237     B::Concise::reset_sequence();
 238     B::Concise::walk_output(\my $buf);
 239
 240     my $walker = B::Concise::compile($func_name);
 241     eval { $walker->() };
 242     diag("err: $@ $buf") if $@;
 243     diag("verbose: $buf") if $opts{V};
 244
 245     return ($buf, $@);
 246 }
 247
 248 sub corecheck {
 249
 250     eval { require Module::CoreList };
 251     if ($@) {
 252         warn "Module::CoreList not available on $]\n";
 253         return;
 254     }
 255     my $mods = $Module::CoreList::version{'5.009002'};
 256     $mods = [ sort keys %$mods ];
 257     print Dumper($mods);
 258
 259     foreach my $pkgnm (@$mods) {
 260         test_pkg($pkgnm);
 261     }
 262 }
 263
 264 END {
 265     if ($opts{c}) {
 266         # print "Corrections: ", Dumper(\%report);
 267         print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
 268         print "\$VAR1 = {\n";
 269
 270         foreach my $pkg (sort keys %report) {
 271             my (@xs, @perl);
 272             my $stash = $report{$pkg};
 273
 274             @xs   = sort grep $stash->{$_} == 1, keys %$stash;
 275             @perl = sort grep $stash->{$_} == 0, keys %$stash;
 276
 277             my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
 278             print "\t$pkg => [qw/ @list /],\n";
 279         }
 280         print "};\n";
 281     }
 282 }
 283
 284 __END__