#! /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();
[download]