#!/usr/local/bin/perl -n

=pod
=begin Id
Id: ${TOOL_ID}
Copyright (C) 2006 Intrinsity, Inc.
Distributed under terms of the Perl license, which is the disjunction of
the GNU General Public License (GPL) and the Artistic License.
=end Id

=begin Description
Description: Extracts specially-formatted comments from a script or
perl module and adds them to the uncoverable database.

The comments have this format:

   # Devel::Cover ['+'<num>] <coverage point>

By default, they attach a coverage point to the next uncommmented line
in the code; but it is possible to attach to a point further down by
putting in the optional '+'<num> where <num> is the number of lines
after the comment to which to attach the coverage point.  (In other
words, if the optional part is left out, it defaults to "+1".)  Thus,
to attach several coverage points to the same line, you could do
something like

   # Devel::Cover +7 <coverage point 1>
   1;   # This line interferes; points above need explicit counts
   # Devel::Cover <coverage point 2>

   # Devel::Cover <coverage point 3>
   # This comment will not interfere.  Neither did the blank line above.
   # Devel::Cover <coverage point 4>
   <the line of code>;

The following types of coverage points are supported.  In all cases, 
the <reason> is just the text of a reason why the coverage point cannot
be hit.

Statement coverage:

   # Devel::Cover statement 0 0 <reason>

Branch coverage:

   # Devel::Cover statement <subline> <branch> <reason>

Condition coverage:

   # Devel::Cover condition <m> <n> <reason>

Subroutine coverage:

   # Devel::Cover subroutine 0 0 <reason>

In the branch coverage, perl uses the same line number for a series of
"if () {} elsif () {} elsif () {}.." statements.  To distinguish these
different branches, Devel::Cover puts each on a separate subline under 
the main line number; it is this quantity that is placed in <subline>
(0 = first line).  <branch> is "0" for T and "1" for F.

For the condition coverage, the <m> and <n> are related in entirely
non-obvious ways to the line in the condition table that they cover.
Here are the <m> <n> values for some common expressions

  A or B   A B dec   m n
           0 0 0     0 2
           0 1 1     0 1
           1 X 1     0 0

  A and B   A B dec   m n
            0 X 0     0 0
            1 0 1     0 1
            1 X 0     0 2

  A and B and C   A B C dec   m n
                  0 X X 0     0 0
                  1 0 X 0     0 1
                  1 1 0 0     1 1
                  1 1 1 1     1 2

  A and (B or C)   Cascades into simpler cases:  0=or, 1=and

  (A and B) or C   A B C dec   m n
                   0 X 0 0   \ 0 0 (not distinguished)
                   0 X 1 1   / 
                   1 0 0 0   \ 0 1 (not distinguished)
                   1 0 1 1   /
                   1 1 X 1     0 2 and 1 0

  A or (B and C)   A B C dec   m n
                   0 0 X 0     0 0
                   0 1 0 0     0 1
                   0 1 1 1     0 2 and 1 1
                   1 X X 1     1 0

  (A or B) and C   Cascades into simpler cases: 0=or, 1=and
                  
  A or B or C   A B C dec   m n
                0 0 0 0     1 2
                0 0 1 1     1 1
                0 1 X 1     0 1
                1 X X 1     0 0

=end Description
=begin Usage
Usage: uncoverable [options] file(s)
Options:
  -cover file  Perl script 'cover' (defaults to searching PATH)
  -d           Print debug information
  -h           Print help
  -V           Print version
=end Usage
=cut

use strict;
use Cwd;
use vars qw($opt_cover $opt_d $opt_h $opt_V);
use vars qw($COVER $TOOL_ID @COVER_LINES);
# Extracts and prints usage information
# Arguments: type of usage, end marker for usage (optional)
sub Usage {
    my ($what) = @_;
    $what = "Usage" if ! $what;
    my $mark = $what eq 'Description' ? "($what|Usage)" : $what;
    if (open(ME, $0) == 1) {
	while (<ME>) {
	    if ((/^=begin $mark/ .. /^=end $mark/) &&
		! /^=(begin|end) $mark/) {
		s/(\$\{[^\}]+\})/eval($1)/ge;
		print;
	    }
	}
	close(ME);
    }
    exit (1);
}

BEGIN {
    my $cvsid = '$Id: uncoverable,v 0.1 2006-07-11 21:21:21Z mnodine $ ';
    $cvsid =~ /Id: (\S+),v (\S+)/;
    $TOOL_ID = "$1 release $2";

    use Getopt::Long;
    Getopt::Long::config('no_ignore_case');
    Usage() unless GetOptions qw(cover=s d h V);
    # Give usage information
    Usage('Description') if $opt_h;
    Usage('Id') if $opt_V;
    Usage() unless @ARGV;
    chomp ($COVER = $opt_cover || `which cover`);
    my $cvsid = '$Id: uncoverable,v 0.1 2006-07-11 21:21:21Z mnodine $ ';
    @COVER_LINES = ();
}

$" = ' ';
if (/^\s*\#\s*Devel::Cover\s+(?:\+(\d+)\s+)?(.*)/) {
    my $fields = $2;
    my $file = Cwd::abs_path($ARGV);
    if ($1) {
	process_cover_lines("$file $fields", $. + $1);
    }
    else {
	push @COVER_LINES, "$file $fields";
    }
}
elsif (/^\s*(?!\#)\S/ && @COVER_LINES) {
    while ($_ = shift @COVER_LINES) {
	process_cover_lines($_);
    }
}

close ARGV if eof;

sub process_cover_lines {
    my ($cover_line, $line) = @_;
    $line = $. if ! defined $line;
    $cover_line =~ s/\'/-/g;  # Remove single quotes
    my ($file, @fields) = split /\s+/, $cover_line;
    my $crit = shift @fields;
    my $cmd = "$^X $COVER -add_uncoverable '$file $crit $line @fields'";
    if ($opt_d) {
	print "$cmd\n" ;
    }
    else {
	print "$file $line ";
	system $cmd;
    }
}
