At file:///Users/hakan/work/monty_program/mariadb-tools/
------------------------------------------------------------
revno: 13 [merge]
revision-id: hakan@askmonty.org-20100303132558-2v3ni7cq5z3me245
parent: hakan@askmonty.org-20100303132525-euyw1c8whdv8fkjl
parent: sergii@pisem.net-20100303125349-tpo8hreru2kugu3k
committer: Hakan Kuecuekyilmaz
branch nick: mariadb-tools
timestamp: Wed 2010-03-03 14:25:58 +0100
message:
Merge.
added:
dgcov.pl dgcov.pl-20100303111408-fyazt0jc6o2obwsh-1
=== added file 'dgcov.pl'
--- a/dgcov.pl 1970-01-01 00:00:00 +0000
+++ b/dgcov.pl 2010-03-03 12:53:49 +0000
@@ -0,0 +1,648 @@
+#! /usr/bin/perl
+
+# Copyright (C) 2003,2008 MySQL AB
+# Copyright (C) 2010 Sergei Golubchik and Monty Program Ab
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; version 2 of the License.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+# Run gcov and report test coverage on only those code lines touched by
+# a given list of revisions.
+
+use strict;
+use warnings;
+
+use Getopt::Long;
+use File::Find;
+use Cwd qw/realpath/;
+use File::Basename;
+
+my $verbose;
+my $all_opt;
+my $context= 3;
+my $help;
+my $purge_opt;
+my $only_gcov_opt;
+my $skip_gcov_opt;
+my $local_opt;
+my $uncommitted_opt;
+
+my $result= GetOptions
+ ("context=i" => \$context,
+ "all" => \$all_opt,
+ "verbose" => \$verbose,
+ "help" => \$help,
+ "purge" => \$purge_opt,
+ "only-gcov" => \$only_gcov_opt,
+ "skip-gcov" => \$skip_gcov_opt,
+ "local" => \$local_opt,
+ "uncommitted" => \$uncommitted_opt,
+ );
+
+usage() if $help;
+
+#
+# In verbose mode we output to STDERR as well as to STDOUT.
+# Avoid misplaced output due to buffering.
+#
+if ($verbose) {
+ select STDERR; $| = 1; # make unbuffered
+ select STDOUT; $| = 1; # make unbuffered
+}
+
+my $troot= `bzr root`;
+chomp $troot;
+if (!$troot || !chdir $troot) {
+ die "Failed to find tree root (this tool must be run within\n" .
+ "a bzr work tree).\n";
+}
+
+my $res;
+my $cmd;
+if ($purge_opt or not $skip_gcov_opt)
+{
+ # One cannot create a file with empty name. But empty argument with -f
+ # makes 'rm' silent when there is no file to remove.
+ $cmd= "find . " .($purge_opt ? "-name '*.da' -o -name '*.gcda' -o " : "").
+ "-name '*.gcov' -o -name '*.dgcov' | grep -v 'README\.gcov' | ".
+ "xargs rm -f ''";
+ print STDERR "Running: $cmd\n" if $verbose;
+ $res= system($cmd);
+ exit ($res ? ($? >> 8) : 0) if $res or $purge_opt;
+
+ # gcov is difficult. source files might be in different places:
+ # 1. in the same directory where the .o file is
+ # 2. in include/ for headers
+ # 3. elsewhere, symlinked
+ # 4. elsewhere, if Makefile specifies a file from a different directory
+ #
+ # because of 2/3/4 one source file may have more than one .gcov file,
+ # and even more than one .gcov file with the same name (like, include/my_sys.h
+ # will have as many files with the name "sql/my_sys.h.gcov" as there are
+ # .o files in the sql directory. these "sql/my_sys.h.gcov" files are
+ # _different_ files with the same name, and different content)
+ #
+ # that's what we'll do here: delete all .gcov and .dgcov files (already done,
+ # see above). run gcov once per every .gcda file, grab all generated .gcov
+ # files and aggregate them with the already existing .dgcov files for the
+ # corresponding source files.
+ #
+ find(\&gcov_one_file, ".");
+
+ exit 0 if $only_gcov_opt;
+}
+
+my @revisions = @ARGV;
+if(@revisions == 0 && !$uncommitted_opt) {
+ $local_opt= 1;
+}
+
+if($local_opt) {
+ # Add revisions present in this tree only.
+ my $cmd= "bzr missing --this";
+ print STDERR "Running: $cmd\n"
+ if $verbose;
+ for $_ (`$cmd`)
+ {
+ next
+ unless /^revno: (.*)/;
+ push @revisions, $1;
+ print STDERR "Added revision $1\n"
+ if $verbose;
+ }
+}
+die "No revision differences to check.\n"
+ if (@revisions == 0 && !$uncommitted_opt);
+
+my $filemap= {};
+# First find all files and their revisions included in the list of revisions.
+for my $cs (@revisions) {
+ # getting the list of revisions
+ my $cmd="bzr log --line -r '$cs'";
+ $cs="$cs..$cs" unless $cs =~ /\.\./;
+ my @revs=();
+ print STDERR "Running: $cmd\n" if $verbose;
+ print STDERR "." if !$verbose and -t STDERR;
+
+ open PIPE, '-|', $cmd
+ or die "Failed to spawn '$cmd': $!: $?\n";
+ while(<PIPE>) {
+ die "unexpected output from '$cmd': $_\n" unless /^(\d+):/;
+ push @revs, $1;
+ }
+ close PIPE or die "subcommand '$cmd' failed: $!: $?\n";
+
+ $cmd= "bzr status --short -r before:'$cs'";
+ print STDERR "Running: $cmd\n" if $verbose;
+ print STDERR "." if !$verbose and -t STDERR;
+
+ open PIPE, '-|', $cmd
+ or die "Failed to spawn '$cmd': $!: $?\n";
+ while(<PIPE>) {
+ die "unexpected output from '$cmd': $_\n" unless /^[- +RX?CP][ NDKM][ *] /;
+ next unless /^( M|\+N). (.*)$/;
+ my $file = $2;
+ next unless -r "$file.dgcov";
+ $filemap->{$file}{$_} = 1 for (@revs);
+ printf STDERR "Added file $file for @revs\n" if $verbose;
+ }
+ close PIPE or die "subcommand '$cmd' failed: $!: $?\n";
+}
+print STDERR "\n" unless $verbose;
+
+my $uncommitted_changes= { };
+if($uncommitted_opt) {
+ $uncommitted_changes= get_uncommitted_changes_unified();
+}
+
+# Next, run 'bzr annotate' and 'gcov' on the source files.
+my $missing_files= 0;
+my $total_lines= 0;
+my $numfiles= 0;
+my $uncovered= 0;
+my $bad_anno_lines= 0;
+
+for my $file (sort keys %$filemap) {
+ my $cmd;
+ my $lines = [ ];
+
+ if (@revisions != 0) {
+ $cmd= "bzr annotate --all '$file'";
+ print STDERR "Running: $cmd\n" if $verbose;
+ open PIPE, '-|', $cmd or die "Failed to spawn '$cmd': $!";
+ my $linenum= 1;
+ while(<PIPE>) {
+ die "Unexpected source line '$_'\n"
+ unless /^([.0-9]+)\??\s+[^|]+ \| (.*)$/;
+ my ($rev, $text)= ($1, $2);
+ # Push line number on list of touched lines if revision matches.
+ if($filemap->{$file}{$rev}) {
+ push @$lines, $linenum;
+ ++$total_lines;
+ }
+ ++$linenum;
+ }
+ close PIPE
+ or die "command '$cmd' failed: $!: $?\n";
+ }
+ $numfiles++;
+
+ my $dgcov_file= "$file.dgcov";
+
+ $lines= apply_diff_to_file($uncommitted_changes->{$file}, $lines)
+ if -r $dgcov_file and $uncommitted_changes->{$file};
+
+ # Skip if no lines actually touched in the file.
+ next unless @$lines;
+
+ # Remember previous N lines to be able to print context.
+ my @prev= ( );
+ # Print N more lines of context.
+ my $pending= 0;
+
+ $res= open FH, '<', $dgcov_file;
+ if(!$res) {
+ warn "Failed to open gcov output file '$dgcov_file'\n".
+ "The file was never run yet ?\n";
+ $missing_files++;
+ die; # can that happen now ?
+ next;
+ }
+
+ my ($mark, $lineno, $src, $full);
+ my $did_header= undef;
+ my $last_lineno= undef;
+
+ my $printer= sub {
+ unless($did_header) {
+ print "\nFile: $file\n", '-' x 79, "\n";
+ $did_header= 1;
+ }
+ print $_[0];
+ $last_lineno= $lineno;
+ };
+
+ my $annotation= undef;
+
+ while(<FH>) {
+ next if /^function /; # Skip function summaries.
+ die "Unexpected line '$_'\n"
+ unless /^([^:]+):[ \t]*([0-9]+):(.*)$/;
+ ($mark, $lineno, $src, $full)= ($1, $2, $3, $_);
+
+ # Check for source annotation for inspected/dead/tested code.
+ if($src =~ m!/\*[ \t]+purecov[ \t]*:[ \t]*(inspected|tested|deadcode)[ \t]+\*/!) {
+ $annotation= 'SINGLE';
+ } elsif($src =~ m!/\*[ \t]+purecov[ \t]*:[ \t]*begin[ \t]+(inspected|tested|deadcode)[ \t]+\*/!) {
+ $annotation= 'RUNNING';
+ } elsif($src =~ m!/\*[ \t]+purecov[ \t]*:[ \t]*end[ \t]+\*/!) {
+ warn "Warning: Found /* purecov: end */ annotation " .
+ "not matched by begin.\n" .
+ " At line $lineno in '$file'.\n"
+ unless defined($annotation) && $annotation eq 'RUNNING';
+ $annotation= undef;
+ } else {
+ $annotation= undef if defined($annotation) && $annotation eq 'SINGLE';
+ }
+
+ shift @prev if @prev > $context;
+
+ if(@$lines == 0 || $lineno < $lines->[0]) {
+ # This line was not touched by any revision. But we might need
+ # to print it as context.
+
+ # For lines printed as context (not touched by any revision)
+ # that are not covered, we make the ##### marker a little less
+ # prominent.
+ $full=~ s/^([ \t]*)\#\#\#\#\#:/"$1+++++:"/e;
+
+ if ($pending > 0) {
+ # Print as context for a previous line included in our revisions.
+ die "Internal error: pending context to print, but \@prev non-empty"
+ if @prev;
+ $pending--;
+ $printer->(".$full");
+ } else {
+ # Not printed now, so save it as context which may be needed later.
+ push @prev, ".$full";
+ }
+ } else {
+ # The line is included in our revision list.
+ shift @$lines;
+
+ # We need to print the line (and any previous context lines)
+ # either if this line is not covered, or if it should be shown as
+ # context for a previous printed line.
+ # However, a purecov: annotation reverses this logic, so we will warn
+ # about an annotated line that is actually covered by the test.
+ if($mark =~ /\#\#\#\#\#/ && !defined($annotation)) {
+ $uncovered++;
+ # Make sure we print this line and following context lines.
+ $pending= $context + 1;
+ }
+ if($mark =~ /^[ \t]*[0-9]+$/ && defined($annotation)) {
+ $bad_anno_lines++;
+ # Make sure we print this line and following context lines.
+ $pending= $context + 1;
+ }
+ if($all_opt) {
+ # In all_opt mode, all lines modified in revisions are printed.
+ $pending= $context + 1;
+ }
+ if($pending > 0) {
+ if(defined($last_lineno) && $last_lineno < $lineno - 1) {
+ # Mark a gap in the printed file with an empty line.
+ print "\n";
+ }
+ $printer->($_) for @prev;
+ @prev = ( );
+ $pending--;
+ $printer->("|$full");
+ } else {
+ # Not printed now, so save it as context which may be needed later.
+ push @prev, "|$full";
+ }
+ }
+ }
+ close FH;
+ print "\n"
+ if ($did_header);
+}
+
+print '-' x 79, "\n\n";
+print "$total_lines line(s) in $numfiles source file(s) modified in revision(s).\n";
+print "$uncovered line(s) not covered by tests.\n";
+print "$bad_anno_lines line(s) with redundant purecov: annotations.\n"
+ if $bad_anno_lines > 0;
+print "$missing_files file(s) not processed with gcov.\n"
+ if $missing_files;
+print "For documentation, see http://forge.mysql.com/wiki/DGCov_doc\n";
+
+exit 0;
+
+###############################################################################
+
+sub get_uncommitted_changes_simple {
+ my $cmd= "bzr diff";
+ print STDERR "Running: $cmd\n"
+ if $verbose;
+ open PIPE, '-|', $cmd
+ or die "Failed to spawn '$cmd': $!";
+
+ my $x= { };
+ my $c= undef;
+
+ while(<PIPE>) {
+ if(/^===== (.*) [0-9]+\.[0-9]+(\.[0-9]+\.[0-9]+)? vs edited =====$/) {
+ $c= [ ];
+ $x->{$1}= $c;
+ $filemap->{$1}{UNCOMMITTED}= 1
+ unless exists($filemap->{$1});
+ printf STDERR "Added file %-14s %s\n", "UNCOMMITTED", $1
+ if $verbose;
+ } elsif(/^([0-9]+)a([0-9]+),([0-9]+)$/) {
+ # Append new lines $2-$3 after old line $1.
+ push @$c, [a => $1, $2, $3];
+ } elsif(/^([0-9]+)a([0-9]+)$/) {
+ push @$c, [a => $1, $2, $2];
+ } elsif(/^([0-9]+),([0-9]+)d([0-9]+)$/) {
+ # Delete old lines $1-$2 after new line $3.
+ push @$c, [d => $1, $2, $3];
+ } elsif(/^([0-9]+)d([0-9]+)$/) {
+ push @$c, [d => $1, $1, $2];
+ } elsif(/^([0-9]+),([0-9]+)c([0-9]+),([0-9]+)$/) {
+ # Change old lines $1-$2 to new lines $3-$4
+ push @$c, [c => $1, $2, $3, $4];
+ } elsif(/^([0-9]+)c([0-9]+),([0-9]+)$/) {
+ push @$c, [c => $1, $1, $2, $3];
+ } elsif(/^([0-9]+),([0-9]+)c([0-9]+)$/) {
+ push @$c, [c => $1, $2, $3, $3];
+ } elsif(/^([0-9]+)c([0-9]+)$/) {
+ push @$c, [c => $1, $1, $2, $2];
+ } elsif(/^([<>]|---)/) {
+ # We are not interested in the actual diff content, just the
+ # line numbers that were changed.
+ } else {
+ die "Unexpected output from '$cmd':\n$_";
+ }
+ }
+
+ return $x;
+}
+
+sub get_uncommitted_changes_unified {
+ my $cmd= "bzr diff --diff-options=-U0";
+ print STDERR "Running: $cmd\n"
+ if $verbose;
+ open PIPE, '-|', $cmd
+ or die "Failed to spawn '$cmd': $!";
+
+ my $x= { };
+ my $c= undef;
+
+ while(<PIPE>) {
+ # Ignore directories.
+ if(/^=== added directory '(.*)'$/) {
+
+ # Collect files.
+ } elsif(/^=== (modified file|added file) '(.*)'$/) {
+ $c= [ ];
+ $x->{$2}= $c;
+ $filemap->{$2}{UNCOMMITTED}= 1
+ unless exists($filemap->{$2});
+ printf STDERR "Added file %-14s %s\n", "UNCOMMITTED", $2
+ if $verbose;
+
+ # Ignore removed files.
+ } elsif(/^=== (removed file) '(.*)'$/) {
+
+ # Ignore file names.
+ } elsif(/^(---|\+\+\+) ./) {
+
+ # Collect changed lines. Ignore those with 0 lines changed.
+ # Change old lines $1-$2 to new lines $3-$4
+ } elsif(/^@@ [+-](\d+),(\d+) [+-](\d+),([1-9]\d*) @@/) {
+ push @$c, [c => $1, $1+$2, $3, $3+$4];
+ } elsif(/^@@ [+-](\d+) [+-](\d+),([1-9]\d*) @@/) {
+ push @$c, [c => $1, $1, $2, $2+$3];
+ } elsif(/^@@ [+-](\d+),(\d+) [+-](\d+) @@/) {
+ push @$c, [c => $1, $1+$2, $3, $3];
+ } elsif(/^@@ [+-](\d+) [+-](\d+) @@/) {
+ push @$c, [c => $1, $1, $2, $2];
+
+ } elsif(/^@@ /) {
+ # Ignore diffs with 0 lines changed.
+
+ } elsif(/^[ +-]|^$/) {
+ # We are not interested in the actual diff content, just the
+ # line numbers that were changed.
+ } else {
+ die "Unexpected output from '$cmd':\n$_";
+ }
+ }
+
+ return $x;
+}
+
+sub apply_diff_to_file {
+ my ($c, $l)= @_;
+ my $i= 0;
+ my $shift= 0;
+ my $l_new= [ ];
+
+ # Copy over line numbers, applying the diffs on the way.
+ for my $d (@$c) {
+ my $t= shift @$d;
+ if($t eq 'a') {
+ my ($old, $from, $to)= @$d;
+ # Find the place to insert the lines.
+ push @$l_new, $l->[$i++] + $shift && ++$total_lines
+ while $i< @$l && $l->[$i] <= $old;
+ push @$l_new, ($from .. $to);
+ ++$total_lines;
+ $shift+= ($to - $from + 1);
+ } elsif($t eq 'd') {
+ my ($from, $to, $new)= @$d;
+ push @$l_new, $l->[$i++] + $shift && ++$total_lines
+ while $i< @$l && $l->[$i] + $shift <= $new;
+ # Skip any deleted lines.
+ $i++
+ while $i< @$l && $l->[$i] <= $to;
+ $shift-= ($to - $from + 1);
+ } elsif($t eq 'c') {
+ my ($ofrom, $oto, $nfrom, $nto)= @$d;
+ push @$l_new, $l->[$i++] + $shift && ++$total_lines
+ while $i< @$l && $l->[$i] < $ofrom;
+ $i++
+ while $i< @$l && $l->[$i] <= $oto;
+ push @$l_new, ($nfrom .. $nto);
+ ++$total_lines;
+ $shift= $shift - ($oto-$ofrom) + ($nto-$nfrom);
+ } else {
+ die "Internal?!?";
+ }
+ }
+ push @$l_new, $l->[$i] + $shift
+ while $i< @$l;
+ return $l_new;
+}
+
+sub usage {
+ print <)
+ {
+ die "not a gcov file?" unless /^\s*(-|#+|\d+):\s*(\d+):/;
+ my ($cnt, $line) = ($1, $2);
+ next if $cnt eq '-';
+ $acc->[$line]+=$cnt;
+ }
+}
+
+my $file_no=0;
+sub gcov_one_file {
+ return unless /\.gcda$/;
+ my $ofile="$`.o";
+ my $sourcepath;
+ my $lastfile;
+
+ $cmd= "gcov '$_'";
+ print STDERR ++$file_no, "\r" if !$verbose and -t STDERR;
+ print STDERR "Running: $cmd\n" if $verbose;
+ my $res= system "$cmd 2>/dev/null >/dev/null";
+ if($res) {
+ warn "Failed to spawn '$_': $res: $!: $?\n".
+ "The gcov report may be incomplete.\n";
+ $missing_files++;
+ die; # can that happen now ?
+ return;
+ }
+ # now, read all generated files
+ for my $file (<*.gcov>) {
+ open FH, '<', $file;
+ $_=<FH>;
+ chomp;
+ # first, we read the name or the source file from the .gcov file
+ # that works pretty well for included headers
+ warn "$File::Find::dir/$file does not start from a Source line ? Weird "
+ unless /^\s+-:\s+0:Source:/;
+ my $sourcefile=$';
+ # remove .libs from the end of the path
+ # for building dynamic libraries libtool puts .o files in the .libs/
+ my $up=($File::Find::dir =~ /\/\.libs$/ ? "../" : "");
+ # and resolve symlinks, we love symlinking sources so much!
+ my $source=realpath($up.$sourcefile);
+ unless ($source and -r $source) {
+ # Hm, let's try to find the file in the same directory where the last
+ # file was.
+ # the only file that needs it is libmysqld/sql_yacc.yy.gcov
+ $source=dirname($lastfile)."/".$sourcefile if $lastfile;
+ }
+ unless ($source and -r $source) {
+ # still no cookie, time to try something new.
+ # sometimes files are not symlinked, but specified in the Makefile with
+ # a path, like file.o: ../foobar/file.c
+ # in that case the ../foobar part is recorded in the .o file
+ unless (defined $sourcepath) {
+ $_=`readelf -wi $ofile|grep -m1 'DW_AT_name.*/' 2>/dev/null`;
+ m!DW_AT_name\s*:\s*(?:\(.*\): )?(\S.*)/[^/]+\n! or
+ die "error running 'readelf -wi $File::Find::dir/$ofile', no 'DW_AT_name.*/' found";
+ print STDERR "Got the path '$1' with 'readelf -wi $File::Find::dir/$ofile'\n" if $verbose;
+ $sourcepath=$1;
+ }
+ $source=realpath("$up$sourcepath/$sourcefile");
+ }
+ die "A source file $source for $File::Find::dir/$up$file does not exists"
+ unless -r $source;
+
+ unless ($source =~ /^$troot/o) {
+ warn "Skipping $source\n";
+ unlink $file;
+ next;
+ }
+ $lastfile=$source;
+
+ my @acc=();
+ print STDERR "Reading: $File::Find::dir/$file\n" if $verbose;
+ suck_in(\@acc, *FH);
+ close FH;
+
+ my $dgcov_file="$source.dgcov";
+ if (-r $dgcov_file) {
+ open (FH, '<', $dgcov_file);
+ print STDERR "Adding: $dgcov_file\n" if $verbose;
+ suck_in(\@acc, *FH);
+ close FH;
+ }
+
+ open (F, '<', $source) or die "cannot read $source";
+ open (FH, '>', $dgcov_file) or die "cannot write to $dgcov_file";
+ print STDERR "Writing: $dgcov_file\n" if $verbose;
+ while (<F>) {
+ printf FH '%9s:%5s:%s',
+ defined ($acc[$.]) ? $acc[$.] || '#####' : '-',
+ $., $_;
+ }
+ close FH;
+ close F;
+ unlink $file;
+ }
+}
+
