# New Ticket Created by [EMAIL PROTECTED]
# Please include the string: [perl #31061]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org:80/rt3/Ticket/Display.html?id=31061 >
Hi,
I found tools/dev/parrot_coverage.pl in freshly updated cvs tree to be
completely broken at least on my workstation:
> cat /etc/redhat-release
Red Hat Linux release 9 (Shrike)
> gcov -v
gcov (GCC) 3.2.2 20030222 (Red Hat Linux 3.2.2-5)
Copyright (C) 2001 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
After applying the attached patch I got all worked. Additionally this
patch eliminates all warnings that appeared with the old version.
Vadim.
Index: tools/dev/parrot_coverage.pl
===================================================================
RCS file: /cvs/public/parrot/tools/dev/parrot_coverage.pl,v
retrieving revision 1.3
diff -u -r1.3 parrot_coverage.pl
--- tools/dev/parrot_coverage.pl 9 Aug 2004 15:09:36 -0000 1.3
+++ tools/dev/parrot_coverage.pl 11 Aug 2004 12:22:44 -0000
@@ -34,7 +34,7 @@
my $HTMLDIR = "parrot_coverage";
my $DEBUG = 1;
-if ($ARGV[0] =~ /recompile/) {
+if ($ARGV[0] && $ARGV[0] =~ /recompile/) {
#### clean up remnants of prior biulds
File::Find::find({wanted => sub {
@@ -43,7 +43,7 @@
}}, $SRCDIR);
#### build parrot with coverage support
- system("perl Configure.pl --cc=\"gcc -fprofile-arcs -ftest-coverage\"");
+ system("perl Configure.pl --ccflags=\"-fprofile-arcs -ftest-coverage\"");
system("make");
#### Now run the tests
@@ -71,8 +71,8 @@
foreach my $da_file (@dafiles) {
my $dirname = dirname($da_file) || ".";
my $filename = basename($da_file);
- my $objectfilename = $da_file;
- $objectfilename =~ s/\.da$//g;
+ my $srcfilename = $da_file;
+ $srcfilename =~ s/\.da$/.c/;
#gcov must be run from the directory that the compiler was invoked from.
#Currently, this is the parrot root directory.
@@ -81,7 +81,7 @@
#Hence, as soon as we know the true name of the object file being profiled,
#we rename the gcov log file.
#The -o flag is necessary to help gcov locate it's basic block (.bb) files.
- my $cmd = "gcov -f -b -o $da_file $objectfilename";
+ my $cmd = "gcov -f -b -o $dirname $srcfilename";
print "Running $cmd..\n" if $DEBUG;
open (GCOVSUMMARY, "$cmd|") || die "Error invoking '$cmd': $!";
my $tmp;
@@ -122,13 +122,13 @@
next;
}
- my ($percent, $total_lines, $function) = /\s*([^%]+)% of (\d+)(?:
source)? lines executed in function (.*)/;
+ ($percent, $total_lines, my $function) = /\s*([^%]+)% of (\d+)(?:
source)? lines executed in function (.*)/;
if ($total_lines) {
$function_line_coverage{$source_file}{$function} = $percent;
next;
}
- my ($percent, $total_branches) = /\s*([^%]+)% of (\d+) branches taken at
least once in file/;
+ ($percent, my $total_branches) = /\s*([^%]+)% of (\d+) branches taken at
least once in file/;
if ($total_branches) {
my $covered_branches = int(($percent/100) * $total_branches);
$totals{branches} += $total_branches;
@@ -137,19 +137,19 @@
next;
}
- my ($percent, $total_branches, $function) = /\s*([^%]+)% of (\d+)
branches taken at least once in function (.*)/;
+ ($percent, $total_branches, $function) = /\s*([^%]+)% of (\d+) branches
taken at least once in function (.*)/;
if ($total_branches) {
$function_branch_coverage{$source_file}{$function} = $percent;
next;
}
- my ($percent, $total_calls, $function) = /\s*([^%]+)% of (\d+) calls
executed in function (.*)/;
+ ($percent, my $total_calls, $function) = /\s*([^%]+)% of (\d+) calls
executed in function (.*)/;
if ($total_calls) {
$function_call_coverage{$source_file}{$function} = $percent;
next;
}
- my ($percent, $total_calls) = /\s*([^%]+)% of (\d+) calls executed in
file/;
+ ($percent, $total_calls) = /\s*([^%]+)% of (\d+) calls executed in file/;
if ($total_calls) {
my $covered_calls = int(($percent/100) * $total_calls);
$totals{calls} += $total_calls;
@@ -330,7 +330,7 @@
close(IN);
- my $outfile = "$outfile_base.branches.html";
+ $outfile = "$outfile_base.branches.html";
print "Writing $outfile..\n" if $DEBUG;
open (IN, "<$infile") || die "Can't read $infile: $!\n";
open (OUT, ">$outfile") || die "Can't write $outfile: $!\n";
@@ -348,7 +348,7 @@
close(IN);
- my $outfile = "$outfile_base.calls.html";
+ $outfile = "$outfile_base.calls.html";
print "Writing $outfile..\n" if $DEBUG;
open (IN, "<$infile") || die "Can't read $infile: $!\n";
open (OUT, ">$outfile") || die "Can't write $outfile: $!\n";
