Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Quick Perl coverage analyzer

by bikeNomad (Priest)
on May 25, 2001 at 23:04 UTC ( #83382=sourcecode: print w/ replies, xml ) Need Help??

Category: Miscellaneous
Author/Contact Info Ned Konz, ned@bike-nomad.com
Description: This uses the debugger to do a quick coverage analysis.

usage: run one script:

coverage script [ arg ... ] > listing.txt

or run multiple tests from a file of tests, one test per line.
coverage @file > listing.txt

output: subroutine summary and annotated listing on STDOUT, '-' signs show the lines that didn't get executed
#! /usr/bin/perl -w
# Perl coverage testing tool.
# Ned Konz 3/10/2000
# ned@bike-nomad.com
# $Revision: 1.1 $
# usage: run one script:
# coverage script [ arg ... ] > listing.txt
# or run multiple tests from a file of tests, one test per line.
# coverage @file > listing.txt
# output: annotated listing on STDOUT.

use strict;

my %coverage;
my %functions;
my $currentFile;
my $currentFunction;

my $tmpfile = `mktemp /tmp/coverageXXXXXX`;

$ENV{PERLDB_OPTS} = "NonStop AutoTrace LineInfo=$tmpfile";
$| = 1;

sub runOneTest
{
 my $test = shift;
 system("perl -d $test") == 0
  or die "can't open debugger: $!\n";

 open(DBOUT, $tmpfile)
  or die "can't open $tmpfile: $!\n";

 while (<DBOUT>)
 {
  if (/^(\D.*)\(([^(]+):(\d+)\):\s*(.*)$/)
  {
   $currentFunction = $1;
   $currentFile = $2;
   my $lineNumber = $3;
   my $otherStuff = $4;
   if (!exists($coverage{$currentFile}))
   {
    $coverage{$currentFile} = [];
   }
   if ($currentFunction !~ /CODE\(/)
   {
    $functions{$currentFunction} = $currentFile;
   }
   if ($otherStuff)
   {
    $coverage{$currentFile}->[$lineNumber] ++;
   }
  }
  elsif (/^(\d+):/)
  {
   $coverage{$currentFile}->[$1] ++;
  }
 }

 unlink $tmpfile;
}

sub printHeader
{
 my $header = shift;
 $header = "$header " if length($header) % 2;
 my $dashLength = (78 - length($header)) / 2;
 $dashLength = 2 if $dashLength < 2;
 print '=' x $dashLength . " $header " . '=' x $dashLength . "\n";
}

sub printSummary
{
 printHeader("FUNCTIONS");
 foreach my $function (sort(keys(%functions)))
 {
  printf "$function\t$functions{$function}\n";
 }

 printHeader("FILE COVERAGE");
 foreach my $file (sort(keys(%coverage)))
 {
  next if ! -r $file;
  next if ($file =~ qr{^/usr/.*/perl}); # skip system paths.
  printHeader($file);
  open(FILE, $file)
   or die "can't open $file: $!\n";
  for (my $lineNumber = 1; <FILE>; $lineNumber++)
  {
   my $prefix = ($coverage{$file}->[$lineNumber]) ? '  ' : '- ';
   $prefix = '  ' if (/^\s*#.*/);
   $prefix = '  ' if (/^sub\s+\w+\s*$/);
   $prefix = '  ' if (/^\s*[{};]*$/);
   $prefix = '  ' if (/^\s*package\s+[\w:]+\s*;\s*$/);
   print $prefix, $_;
  }
  close(FILE);
 }
}

# main program.

if ($ARGV[0] =~ /^@(.*)/)
{
 open(TESTS, $1);
 foreach my $test (<TESTS>)
 {
  chomp($test);
  print STDERR "Running $test\n";
  printHeader("Running $test");
  runOneTest($test);
 }
}
else
{
 runOneTest("@ARGV");
}

printSummary();

Comment on Quick Perl coverage analyzer
Download Code
Re: Quick Perl coverage analyzer
by Coldstone (Acolyte) on Aug 04, 2006 at 16:22 UTC
    Seems cool, but I guess my perl inst is different somehow ...
    Compilation failed in require at /usr/lib/perl5/5.8.0/utf8.pm line 17. Compilation failed in require at regExTest3.pl line 3. main::BEGIN() called at /usr/lib/perl5/5.8.0/strict.pm line 3 eval {...} called at /usr/lib/perl5/5.8.0/strict.pm line 3 BEGIN failed--compilation aborted at regExTest3.pl line 3. can't open debugger: Bad file descriptor

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://83382]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (18)
As of 2014-07-11 19:37 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    When choosing user names for websites, I prefer to use:








    Results (235 votes), past polls