B::Concise torture
Jim Cromie [Thu, 2 Jun 2005 06:36:00 +0000 (06:36 +0000)]
Message-ID: <429E8CBE.406@divsol.com>
(with formatting nits)

p4raw-id: //depot/perl@24700

ext/B/B/Concise.pm
ext/B/t/concise-xs.t

index 9386e01..0798716 100644 (file)
@@ -631,6 +631,7 @@ sub concise_sv {
     $hr->{svclass} = class($sv);
     $hr->{svclass} = "UV"
       if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
+    Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
     $hr->{svaddr} = sprintf("%#x", $$sv);
     if ($hr->{svclass} eq "GV") {
        my $gv = $sv;
@@ -759,19 +760,18 @@ sub concise_op {
     } elsif ($h{class} eq "LOGOP") {
        undef $lastnext;
        $h{arg} = "(other->" . seq($op->other) . ")";
-    } elsif ($h{class} eq "SVOP") {
+    }
+    elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
        unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
-           if (! ${$op->sv}) {
-               my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ];
+           my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
+           if ($h{class} eq "PADOP" or !${$op->sv}) {
+               my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
                $h{arg} = "[" . concise_sv($sv, \%h) . "]";
                $h{targarglife} = $h{targarg} = "";
            } else {
                $h{arg} = "(" . concise_sv($op->sv, \%h) . ")";
            }
        }
-    } elsif ($h{class} eq "PADOP") {
-       my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
-       $h{arg} = "[" . concise_sv($sv, \%h) . "]";
     }
     $h{seq} = $h{hyphseq} = seq($op);
     $h{seq} = "" if $h{seq} eq "-";
index a464087..e72a180 100644 (file)
@@ -2,11 +2,11 @@
 
 # 2 purpose file: 1-test 2-demonstrate (via args, -v -a options)
 
-=head1 synopsis
+=head1 SYNOPSIS
 
 To verify that B::Concise properly reports whether functions are XS or
 perl, we test against 2 (currently) core packages which have lots of
-XS functions; B and Digest::MD5.  They're listed in %$testpkgs, along
+XS functions: B and Digest::MD5.  They're listed in %$testpkgs, along
 with a list of functions that are (or are not) XS.  For brevity, you
 can specify the shorter list; if they're non-xs routines, start list
 with a '!'.  Data::Dumper is also tested, partly to prove the non-!
@@ -16,14 +16,58 @@ We demand-load each package, scan its stash for function names, and
 mark them as XS/not-XS according to the list given for each package.
 Then we test B::Concise's report on each.
 
+=head1 OPTIONS AND ARGUMENTS
+
+C<-v> and C<-V> trigger 2 levels of verbosity.
+
+C<-a> uses Module::CoreList to run all core packages through the test, which
+gives some interesting results.
+
+C<-c> causes the expected XS/non-XS results to be marked with
+corrections, which are then reported at program END, in a
+Data::Dumper statement
+
+C<< -r <file> >> reads a file, as written by C<-c>, and adjusts the expected
+results accordingly.  The file is 'required', so @INC settings apply.
+
 If module-names are given as args, those packages are run through the
 test harness; this is handy for collecting further items to test, and
 may be useful otherwise (ie just to see).
 
-If -a option is given, we use Module::CoreList to run all packages,
-which gives some interesting results.
+=head1 EXAMPLES
+
+All following examples avoid using PERL_CORE=1, since that changes @INC
+
+=over 4
+
+=item ./perl -Ilib -wS ext/B/t/concise-xs.t -c Storable
+
+Tests Storable.pm for XS/non-XS routines, writes findings (along with
+test results) to stdout.  You could edit results to produce a test
+file, as in next example
+
+=item ./perl -Ilib -wS ext/B/t/concise-xs.t -r ./storable
 
--v and -V trigger 2 levels of verbosity.
+Loads file, and uses it to set expectations, and run tests
+
+=item ./perl -Ilib -wS ext/B/t/concise-xs.t -avc > ../foo-avc 2> ../foo-avc2
+
+Gets module list from Module::Corelist, and runs them all through the
+test.  Since -c is used, this generates corrections, which are saved
+in a file, which is edited down to produce ../all-xs
+
+=item ./perl -Ilib -wS ext/B/t/concise-xs.t -cr ../all-xs > ../foo 2> ../foo2
+
+This runs the tests specified in the file created in previous example.
+-c is used again, and stdout verifies that all the expected results
+given by -r ../all-xs are now seen.
+
+Looking at ../foo2, you'll see 34 occurrences of the following error:
+
+# err: Can't use an undefined value as a SCALAR reference at
+# lib/B/Concise.pm line 634, <DATA> line 1.
+
+=back
 
 =cut
 
@@ -46,25 +90,43 @@ use Getopt::Std;
 use Carp;
 use Test::More tests => ( 1 * !!$Config::Config{useithreads}
                          + 2 * ($] > 5.009)
-                         + 272);
+                         + 776);
 
 require_ok("B::Concise");
 
 my $testpkgs = {
-
+    
     Digest::MD5 => [qw/ ! import /],
-
+      
     B => [qw/ ! class clearsym compile_stats debug objsym parents
              peekop savesym timing_info walkoptree_exec
              walkoptree_slow walksymtable /],
 
     Data::Dumper => [qw/ bootstrap Dumpxs /],
+
+    B::Deparse => [qw/ ASSIGN CVf_ASSERTION CVf_LOCKED CVf_LVALUE
+                  CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
+                  OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
+                  OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
+                  OPf_WANT_VOID OPpCONST_ARYBASE OPpCONST_BARE
+                  OPpENTERSUB_AMPER OPpEXISTS_SUB OPpITER_REVERSED
+                  OPpLVAL_INTRO OPpOUR_INTRO OPpSLICE OPpSORT_DESCEND
+                  OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
+                  OPpSORT_REVERSE OPpTARGET_MY OPpTRANS_COMPLEMENT
+                  OPpTRANS_DELETE OPpTRANS_SQUASH PMf_CONTINUE
+                  PMf_EVAL PMf_EXTENDED PMf_FOLD PMf_GLOBAL PMf_KEEP
+                  PMf_MULTILINE PMf_ONCE PMf_SINGLELINE PMf_SKIPWHITE
+                  POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
+                  SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN main_cv
+                  main_root main_start opnumber perlstring
+                  svref_2object /],
+
 };
 
 ############
 
 B::Concise::compile('-nobanner');      # set a silent default
-getopts('vaV', \my %opts) or
+getopts('vaVcr:', \my %opts) or
     die <<EODIE;
 
 usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
@@ -72,7 +134,9 @@ usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list]
     -v : runs verbosely
     -V : more verbosity
     -a : runs all modules in CoreList
-    <args> : additional modules are loaded and tested
+    -c  : writes test corrections as a Data::Dumper expression
+    -r <file>  : reads file of tests, as written by -c
+    <args>     : additional modules are loaded and tested 
        (will report failures, since no XS funcs are known aprior)
 
 EODIE
@@ -84,13 +148,26 @@ if (%opts) {
     $Data::Dumper::Sortkeys = 1;
 }
 my @argpkgs = @ARGV;
-
-foreach $pkg (sort(keys %$testpkgs), @argpkgs) {
-    test_pkg($pkg, $testpkgs->{$pkg});
+my %report;
+
+if ($opts{r}) {
+    my $refpkgs = require "$opts{r}";
+    $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs;
+}    
+
+unless ($opts{a}) {
+    unless (@argpkgs) {
+       foreach $pkg (sort keys %$testpkgs) {
+           test_pkg($pkg, $testpkgs->{$pkg});
+       }
+    } else {
+       foreach $pkg (@argpkgs) {
+           test_pkg($pkg, $testpkgs->{$pkg});
+       }
+    }
+} else {
+    corecheck();
 }
-
-corecheck() if $opts{a};
-
 ############
 
 sub test_pkg {
@@ -101,10 +178,10 @@ sub test_pkg {
        warn "no XS/non-XS function list given, assuming empty XS list";
        $xslist = [''];
     }
-
+    
     my $assumeXS = 0;  # assume list enumerates XS funcs, not perl ones
-    $assumeXS = 1      if $xslist->[0] eq '!';
-
+    $assumeXS = 1      if $xslist->[0] and $xslist->[0] eq '!';
+    
     # build %stash: keys are func-names, vals: 1 if XS, 0 if not
     my (%stash) = map
        ( ($_ => $assumeXS)
@@ -112,22 +189,27 @@ sub test_pkg {
               => grep !/__ANON__/              # but not anon subs
               => keys %{$pkg_name.'::'}        # from symbol table
               ));
-
+    
     # now invert according to supplied list
     $stash{$_} = int ! $assumeXS foreach @$xslist;
-
+    
     # and cleanup cruft (easier than preventing)
     delete @stash{'!',''};
 
-    if (%opts) {
+    if ($opts{v}) {
        diag("xslist: " => Dumper($xslist));
        diag("$pkg_name stash: " => Dumper(\%stash));
     }
-
+    my $err;
     foreach $func_name (reverse sort keys %stash) {
-       $DB::single = 1 if $func_name =~ /AUTOLOAD/;
-       checkXS("${pkg_name}::$func_name", $stash{$func_name});
+       my $res = checkXS("${pkg_name}::$func_name", $stash{$func_name});
+       if (!$res) {
+           $stash{$func_name} ^= 1;
+           print "$func_name ";
+           $err++;
+       }
     }
+    $report{$pkg_name} = \%stash if $opts{c} and $err || $opts{v};
 }
 
 sub checkXS {
@@ -159,17 +241,39 @@ sub render {
 }
 
 sub corecheck {
+
     eval { require Module::CoreList };
     if ($@) {
        warn "Module::CoreList not available on $]\n";
        return;
     }
-    my $mods = $Module::CoreList::version{'5.009001'}; # $]}; # undef ??
+    my $mods = $Module::CoreList::version{'5.009002'};
+    $mods = [ sort keys %$mods ];
     print Dumper($mods);
 
-    foreach my $pkgnm (sort keys %$mods) {
+    foreach my $pkgnm (@$mods) {
        test_pkg($pkgnm);
     }
 }
 
+END {
+    if ($opts{c}) {
+       # print "Corrections: ", Dumper(\%report);
+       print "# Tested Package Subroutines, 1's are XS, 0's are perl\n";
+       print "\$VAR1 = {\n";
+
+       foreach my $pkg (sort keys %report) {
+           my (@xs, @perl);
+           my $stash = $report{$pkg};
+
+           @xs   = sort grep $stash->{$_} == 1, keys %$stash;
+           @perl = sort grep $stash->{$_} == 0, keys %$stash;
+
+           my @list = (@xs > @perl) ? ( '!', @perl) : @xs;
+           print "\t$pkg => [qw/ @list /],\n";
+       }
+       print "};\n";
+    }
+}
+
 __END__