develooper Front page | perl.qa | Postings from December 2016

Devel::Cover force adding unseen files - feedback requested.

Thread Next
From:
Jason Pyeron
Date:
December 26, 2016 02:38
Subject:
Devel::Cover force adding unseen files - feedback requested.
Message ID:
AE072ADA2B2F4FB79AC38DF18B573A6E@black7
Coverage works great as part on continuous integration, until a new file is added and the unit tests are blissfully ignorant of the new file's existence.

In the past with other coverage tools we would scan the source tree and do some mock operation to get the coverage tool to become aware of the source file.

Sometimes it is a bit messy, sometimes not. I think this one falls into the a little bit messy, because we had to go the internals of Devel::Cover::DB and reproduce how Cover.pm uses it.

Below is the script we are using. It provides the minimum functionality required, showing the file as 0% covered.

Does anyone have better suggestions?

-Jason Pyeron


#!/usr/bin/perl -w

use Time::HiRes qw(time);
use Data::Dumper;
use File::Find;
use Cwd;

print "load\n";

use Devel::Cover::DB;

my $dbpath="cover_db";
my $db = Devel::Cover::DB->new(db => $dbpath);
my $timeStart=time;
my $runKey="$timeStart.$$";
my %known;

print "ingest\n";

find({ wanted => \&process_coverfile, no_chdir => 1 }, "$dbpath/runs/");
find({ wanted => \&process_coverfile, no_chdir => 1 }, "$dbpath/digests");
find({ wanted => \&process_coverfile, no_chdir => 1 }, "$dbpath/structure/");

sub process_coverfile
{
    if (-f $_)
    {
        my $x=$db->read($_);
        foreach my $run ($x->runs)
        {
            my $h=$run->{digests};
            foreach my $file (keys %$h)
            {
                if ( ! exists $known{$file} )
                {
                    $known{$file}=$run->{digests}{$file};
                }
            }
        }
    }
}

print scalar keys %known, " known covered file(s) found\n";

print "preprocess\n";

my %toadd;

find({ wanted => \&process_file, no_chdir => 1 }, "scripts");

sub process_file
{
    if (-f $_)
    {
        if ( ! exists $known{$_} )
        {
            $toadd{$_}=Devel::Cover::DB::Structure->digest($_);
        }
    }
}

print scalar keys %toadd, " uncovered file(s) found and hashed\n";


print "process\n";

if (scalar keys %toadd == 0)
{
    print "no files to process\n";
    exit;
}

print "run: $runKey\n";

$db->{runs}{$runKey}{"OS"}=$^O;
$db->{runs}{$runKey}{"collected"}=["branch","condition","pod","statement","subroutine","time"];
$db->{runs}{$runKey}{"dir"}=Cwd::abs_path();
$db->{runs}{$runKey}{"vec"}={};
$db->{runs}{$runKey}{"start"}=$timeStart;
$db->{runs}{$runKey}{"run"}=$0;
$_=$^V;
s/v//;
$db->{runs}{$runKey}{"perl"}=$_;

my $s=$db->{structure}=Devel::Cover::DB::Structure->new;

foreach my $file (keys %toadd)
{
    $db->{structure}->{f}{$file}{start}{-1}{"__COVER__"}[0]{"branch"}=undef;
    $db->{structure}->{f}{$file}{start}{-1}{"__COVER__"}[0]{"condition"}=undef;
    $db->{structure}->{f}{$file}{start}{-1}{"__COVER__"}[0]{"pod"}=undef;
    $db->{structure}->{f}{$file}{start}{-1}{"__COVER__"}[0]{"subroutine"}=undef;
    $db->{structure}->{f}{$file}{start}{-1}{"__COVER__"}[0]{"time"}=undef;
    $db->{structure}->{f}{$file}{start}{-1}{"__COVER__"}[0]{"statement"}=0;
    $db->{structure}->{f}{$file}{file}=$file;
    $db->{structure}->{f}{$file}{digest}=$toadd{$file};
    $db->{structure}->{f}{$file}{statement}=[1];
    $db->{runs}{$runKey}{"count"}{$file}{'statement'}=[0];
    $db->{runs}{$runKey}{"digests"}{$file}=$toadd{$file};
}

$db->{runs}{$runKey}{"finish"}=time;

print "saving\n";

$db->write("$dbpath/runs/$runKey");

--
-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
-                                                               -
- Jason Pyeron                      PD Inc. http://www.pdinc.us -
- Principal Consultant              10 West 24th Street #100    -
- +1 (443) 269-1555 x333            Baltimore, Maryland 21218   -
-                                                               -
-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About