imcover.perl

   1 #!perl -w
   2 use strict;
   3 use Config;
   4 use ExtUtils::Manifest 'maniread';
   5 use Cwd;
   6 use Getopt::Long;
   7
   8 my @tests;
   9 my $verbose;
  10 my $nodc;
  11 GetOptions("t|test=s" => \@tests,
  12            "n" => \$nodc,
  13            "v" => \$verbose)
  14   or die;
  15
  16 my $make = $Config{make};
  17 # if there's a way to make with profiling for a recursive build like
  18 # Imager I don't see how
  19 if (-f 'Makefile') {
  20   run("$make clean");
  21 }
  22 run("cover -delete");
  23 run("perl Makefile.PL --coverage @ARGV")
  24   and die;
  25 run("$make 'OTHERLDFLAGS=-ftest-coverage -fprofile-arcs'")
  26   and die;
  27
  28 {
  29   local $ENV{DEVEL_COVER_OPTIONS} = "-db," . getcwd() . "/cover_db,-coverage,statement,branch,condition,subroutine";
  30   my $makecmd = "$make test TEST_VERBOSE=1";
  31   $makecmd .= " HARNESS_PERL_SWITCHES=-MDevel::Cover" unless $nodc;
  32   if (@tests) {
  33     $makecmd .= " TEST_FILES='@tests'";
  34   }
  35   run($makecmd);
  36 }
  37
  38 # build gcov files
  39 my $mani = maniread();
  40 # split by directory
  41 my %paths;
  42 for my $filename (keys %$mani) {
  43   next unless $filename =~ /\.(xs|c|im)$/;
  44   (my $gcda = $filename) =~ s/\.\w+$/.gcda/;
  45   next unless -f $gcda;
  46   if ($filename =~ m!^(\w+)/(\w+\.\w+)$!) {
  47     push @{$paths{$1}}, $2;
  48   }
  49   else {
  50     push @{$paths{''}}, $filename;
  51   }
  52 }
  53
  54 for my $path (keys %paths) {
  55   if ($path) {
  56     run("cd $path ; gcov -abc @{$paths{$path}} ; cd ..");
  57   }
  58   else {
  59     run("gcov -abc @{$paths{$path}}");
  60   }
  61   my $dir = $path ? $path : '.';
  62   for my $file (@{$paths{$path}}) {
  63     run("gcov2perl $dir/$file.gcov");
  64   }
  65 }
  66
  67 my @dbs = "cover_db", map "$_/cover_db", grep $_, keys %paths;
  68 # we already ran gcov
  69 run("cover -nogcov -ignore_re '^t/'");
  70
  71 sub run {
  72   my $cmd = shift;
  73
  74   print "Running: $cmd\n" if $verbose;
  75   return system $cmd;
  76 }