p4pr.perl #14

#!/usr/bin/perl

use strict;
use warnings;
use File::Basename;
use Getopt::Long;

# $Id: //guest/jonathan_kamens/p4pr.perl#14 $

# Interpolate change information into a source listing of a p4 file.
# Takes a file name or depot filename, with #<ref> or @<change>.
# Originally by Bob Sidebotham.
# Modifications by Jonathan Kamens <jik@kamens.brookline.ma.us> to
# support annotating changes back through branchings, rather than
# only annotating back to revision 1 on the current branch.

# Simplify program name, if it is a path.
my $whoami = basename $0;

my $P4 = ($ENV{'P4'} || "p4") ;

use vars qw($opt_after $print_line_numbers);

$print_line_numbers = 0;

# Execute a command, keeping the output of the command in an array.
# Returns the array, unless an error occured, in which case the an
# exception is thrown (via die) with an appropriate message.
sub command {
    my(@command) = @_;
    # Quote magic characters in each argument in the command
    map(s/([ #])/"$1"/g, @command);
    my(@results) = `@command`;
    if ($?) {
	my($err) = ($? >> 8);
	print STDERR @results;
	die qq($whoami: "@command" exited with status $err.\n);
    }
    @results
}

# Fatal usage error
sub usage {
    my($err) = @_;
    warn "$whoami: $err\n" if ($err);
    die ("Usage: $whoami [-n] [ --after=YYYY/MM/DD ] <file> | <file>#<rev> | " .
         "<file>\@<change>\n" .
	 " -n means print a line number on each output line\n" .
         " <file> may be a client file name or depot file name.\n");
}

usage() if (! GetOptions("after=s" => \$opt_after,
			 "n" => \$print_line_numbers));

usage("invalid date \"$opt_after\"")
    if ($opt_after && $opt_after !~ /^\d{4}(\/\d{2}){2}$/);

# Get file argument.
usage("file name expected") if !@ARGV;
usage("invalid argument") if @ARGV > 1;
my $file = shift;

# Handle # and @ notation (only for numeric changes and revisions).
my $change = $1 if $file =~ s/@(\d+)//;
my $head = $1 if $file =~ s/\#(\d+)//;

# Check that the file specification maps to exactly one file.
my $check_file;
if ($change) {
    $check_file = "$file\@$change";
}
elsif ($head) {
    $check_file = "$file\#$head";
}
else {
    $check_file = $file;
}

my(@list) = command($P4, 'files', $check_file);
if (@list > 1) {
    die("$whoami: the specified file pattern maps to more than one file.\n");
}

# Check that the revision is not deleted.
if ($list[0] =~ /(.*\#\d+) - delete change/) {
    die("$whoami: revision $1 is deleted.\n")
}

# Get the fullname of the file and the history, all from
# the filelog for the file.
my($fullname, @history) = command($P4, 'filelog', '-i', $check_file);
chop($fullname);
$fullname =~ s/\#.*//;
my(@fullname) = split(m./., $fullname);

my $thisname = $fullname;

# Extract the revision to change number mapping. Also
# get the author of each revision, and for merged
# or copied revisions, the "branch name", which we
# use instead of an author.
my(%change, @change, %author, %date, $thisbranch, $thisrev, $headseen);
for (@history) {
    if (m,^//,) {
        chop($thisname = $_);
        next;
    }
    if (/^\.\.\. \#(\d+)\s+change\s+(\d+)\s+(\S+)\s+on\s+(\S+)\s+by\s+(\S+)@/) {
        my $this_rev = $1;
        my $this_change = $2;
        my $this_type = $3;
        my $this_date = $4;
        my $this_author = $5;
	last if ($this_type eq "delete");
        last if ($opt_after && ($this_date lt $opt_after));
	# If a change number or revision is specified, then ignore
	# later revisions.
	next if ($change && ($change < $this_change));
	next if ($head && ($fullname eq $thisname) && ($head < $this_rev));
	$change{"$thisname#$this_rev"} = $this_change;
        push(@change, "$thisname#$this_rev");
 	$author{"$thisname#$this_rev"} = $thisbranch ? 
                 "$this_author\@$thisbranch" : $this_author;
		  $date{"$thisname#$this_rev"} = $this_date;
	$head = $this_rev if !$head;
 	$thisrev = "$thisname#$this_rev";
	$headseen = 1;
    } else {
	# If we see a branch from, then we know that
	# previous revisions did not contribute to the current
	# revision. Don't do this, however, if we haven't seen
	# the revision we've been requested to print, yet.
	# We used to do this for copy from, but I think
	# it's better not to.
	next unless $headseen;
	if (/^\.\.\. \.\.\. branch from (\/\/[^\#]*)\#/) {
	    # If merged or copied from another part of the
	    # tree, then we use the components of the
	    # name that is different, and call that the "branch"
	    # Further, we make the "author" be the name of the
	    # branch.
	    my($fromfile) = $1;
	    my(@from) = split(m,/,, $fromfile);
            $thisbranch = &find_branch_part($fullname, $fromfile);
            $author{$thisrev} = $thisbranch;
	}
    }
}

usage("no revisions after $opt_after") if ($opt_after && ! @change);

sub find_branch_part {
    # Strips identical substrings from the beginning and end of
    # $origname and $branchname and then returns what remains of
    # $branchname.
    my($origname, $branchname) = @_;
    my(@origname) = split('/', $origname);
    my(@branchname) = split('/', $branchname);
    while (@origname && ($origname[0] eq $branchname[0])) {
        shift @origname;
        shift @branchname;
    }
    while (@origname &&
           ($origname[@origname-1] eq $branchname[@branchname-1])) {
        pop @origname;
        pop @branchname;
    }
    join('/', @branchname);
}

# Get first revision, and list of remaining revisions
my($base, @revs) = reverse @change;

# Get the contents of the base revision of the file,
# purely for the purposes of counting the lines.
my(@text) = command($P4, 'print', '-q', $base);

# For each line in the file, set the change revision
# to be the base revision.
my(@lines) = ($base) x @text;

# For each revision from the base to the selected revision
# "apply" the diffs by manipulating the array of revision
# numbers. If lines are added, we add a corresponding 
# set of entries with the revision number that added it.
# We ignore the actual revision text--that will be merged
# with the change information later.
my $lastrev = $base;
for my $rev (@revs) {
    # Apply the diffs in reverse order to maintain correctness
    # of line numbers for each range as we apply it.
    for (reverse command($P4, 'diff2', $lastrev, $rev)) {
	my( $la, $lb, $op, $ra, $rb ) = /^(\d+),?(\d*)([acd])(\d+),?(\d*)/;
	next unless defined($ra);
	$lb = $la if ! $lb;
	++$la if $op eq 'a';
	$rb = $ra if ! $rb;
	++$ra if $op eq 'd';
	splice @lines, $la - 1, $lb - $la + 1, ($rev) x ($rb - $ra + 1);
    }
    $lastrev = $rev;
}
			
# Get the text of the selected revision. The number of lines
# resulting from applying the diffs should equal the number of
# of lines in this revision.
my $header;
($header, @text) = command($P4, 'print', "$file#$head");
if (@text != @lines) {
    die("$whoami: internal error applying diffs - please contact the author\n")
}    

# Print a pretty header.
my $fmt = "%10s %15s %6s %4s %s";
my(@fields) = ("date", "author/branch", "change", "rev", $header);

if ($print_line_numbers) {
    $fmt = "%5s $fmt";
    unshift(@fields, "line");
}

printf($fmt, @fields);
printf("$fmt\n", map('-' x length($_), @fields));

# Interpolate the change author and number into the text.
my($line) = 1;
while (@text) {
    my($rev) = shift(@lines);
    my($revno);

    ($revno = $rev) =~ s,.*\#,,;
    my(@values) = ($date{$rev}, $author{$rev}, $change{$rev}, $revno,
		   shift @text);
    if ($print_line_numbers) {
	unshift(@values, $line++);
    }
    printf($fmt, @values);
}