#!/usr/bin/perl

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

# 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.

# Modifications by Vivek Dasmohapatra <vivek@etla.org> to clean
# up and apply use strict.

use vars qw($PROG $P4 %OPT);
use constant GETOPT_OPTS =>
  qw(auto_abbrev no_getopt_compat require_order bundling);

# handy debugging thingies: give one-line stack backtrace:
use constant TAXES  =>
  sub
  {
      my $i = 0;
      my @stack;
      my $stamp = scalar(gmtime());

      my($pa,$fi,$li,$fu);

    STACKFRAME:
      while(caller(++$i))
      {
          my($pack,$file,$line,$func) = caller($i);

          if( !$pa ) { ($pa,$fi,$li,$fu) = ($pack,$file,$line,$func) }

          push( @stack, $func );
      }

      CORE::warn( "[$stamp] $fi\@$li: ",join(' <- ', @stack)," - ", @_ );
  };

use constant DEATH  =>
  sub
  {
      if( $^S ) { die( @_ ) }
      else
      {
          my($pack,$file,$line,$func) = caller(1);
          my $stamp = scalar(gmtime());
          my $locn  = ($file && $line) ? join('', ' ', $file, '@', $line) : '';
          die( "[$stamp]$locn: $func - ", @_ );
      }
  };

# Simplify program name, if it is a path.
BEGIN
{
    if( $ENV{DEBUG} > 1 )
    {
        $SIG{__WARN__} = TAXES;
        $SIG{__DIE__ } = DEATH;
    }
    $PROG = File::Basename::basename( $0 );
    $P4   = ( $ENV{P4} || 'p4' );
    Getopt::Long::Configure( GETOPT_OPTS );
}

sub command          (;@);
sub usage            (;$);
sub getopts          (\%@);
sub find_branch_part ($$);
sub main             ();

sub DEBUG (;@) { $ENV{DEBUG} && warn(@_) }

main();

############################################################################

# 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) = map { quotemeta } @_;
    my(@results) = `@command`;

    if ($?)
    {
        print(STDERR @results);
	die($PROG, qq|: "@command" exited with status |,($? >> 8), ".\n");
    }

    return @results;
}

# Fatal usage error
sub usage (;$)
{
    my $err = $_[0];

    $err && warn("$PROG: $err\n");

    die(<<TXT);
Usage:
  $PROG [ --after=YYYY/MM/DD ] <file> | <file>#<rev> | <file>\@<change>

  <file> may be a client file name or depot file name.

TXT
}

sub getopts (\%@)
{
    my $opt = shift(@_);
    grep { s/^--?no-/--no/ } @ARGV;
    Getopt::Long::GetOptions($opt, @_);
}

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    = $_[0];
    my $branchname  = $_[1];
    my(@origname)   = split( '/', $origname   );
    my(@branchname) = split( '/', $branchname );

    while( @origname && ($origname[0] eq $branchname[0]) )
    {
        shift(@origname  );
        shift(@branchname);
    }

    while( @origname &&
	   ($origname[$#origname] eq $branchname[$#branchname]) )
    {
        pop( @origname   );
        pop( @branchname );
    }

    return join( '/', @branchname );
}


sub main ()
{
    my %author;
    my @change;
    my %change;
    my $change;
    my $head;
    my $check_file;

    if (! getopts(%OPT,"after=s") ) { usage() }

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

    # Get file argument.
    if( !@ARGV    ) { usage("file name expected") }
    if( @ARGV > 1 ) { usage("invalid argument"  ) }

    my $file = $ARGV[0];

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

    # Check that the file specification maps to exactly one 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("$PROG: 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("$PROG: 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); Doesn't appear to be used.

    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 $thisrev;
    my $thisbranch;
    my $headseen;

    for (@history)
    {
        if ( m,^//, )
        {
            chop( $thisname = $_ );
            next;
        }

        if(/^\.{3} #(\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;

	    DEBUG("last branch: $thisbranch\n");
	    DEBUG("f/this name: $fullname/$thisname\n");

            ( $this_type eq "delete"                     ) && last;
            ( $OPT{after} && ($this_date lt $OPT{after}) ) && last;

            # If a change number or revision is specified, then ignore
            # later revisions.
            ($change && ($change < $this_change)                     ) && next;
            ($head && ($fullname eq $thisname) && ($head < $this_rev)) && next;

            $change{"$thisname#$this_rev"} = $this_change;

            push(@change, "$thisname#$this_rev");

            $author{"$thisname#$this_rev"} =
              $thisbranch ? join('@',$this_author,$thisbranch) : $this_author;

            $head    ||= $this_rev;
            $thisrev   = "$thisname#$this_rev";
            $headseen  = 1;
        }
        elsif( $headseen && /^\.\.\. \.\.\. branch from (\/\/[^#]*)\#/ )
        {
            # 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.

	    # 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;
        }
    }

    if( $OPT{after} && !@change ){ usage("no revisions after $OPT{after}") }

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

    DEBUG("BASE  : $base\n");
    DEBUG("REVS  : @revs\n");
    DEBUG("CHANGE: ", join(", ", %change), "\n");

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

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

    DEBUG("\@lines = ",scalar(@lines)," [initially]\n");
    # 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;

    foreach my $rev (@revs)
    {
        # Apply the diffs in reverse order to maintain correctness
        # of line numbers for each range as we apply it.
	DEBUG("diff2 $lastrev $rev\n");
        foreach (reverse( command($P4, 'diff2', $lastrev, $rev) ) )
        {
	    #print(STDOUT " REV-: $_");

            my( $la, $lb, $op, $ra, $rb ) = /^(\d+),?(\d*)([acd])(\d+),?(\d*)/;
            defined($ra) || next;

	    DEBUG(" REVM: [$ra] matched: ($lastrev,$rev): $_");

            ( $lb        ) || ( $lb = $la ); #if ! $lb;
            ( $op eq 'a' ) && ( ++$la     ); #if $op eq 'a';
            ( $rb        ) || ( $rb = $ra ); #if ! $rb;
            ( $op eq 'd' ) && ( ++$ra     ); #if $op eq 'd';

            splice( @lines                       ,
                    ( $la - 1                  ) ,
                    ( $lb - $la + 1            ) ,
                    ( ($rev) x ($rb - $ra + 1) ) );
        }

        $lastrev = $rev;
    }

    DEBUG("\@lines = ",scalar(@lines)," [postmangle]\n");

    # 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, @text) = command($P4, 'print', "$file#$head");

    DEBUG("filespec: $file#$head\n");

    if (@text != @lines)
    {
        die("$PROG: error applying diffs: Please contact the author\n");
    }

    # Print a pretty header. Note that the interpolated information
    # at the beginning of the line is a multiple of 8 bytes (currently 24)
    # so that the default tabbing of 8 characters works correctly.
    my $fmt     = '%5s %15s %6s %4s %s';
    my(@fields) = (qw(line author/branch change rev), $header);

    printf(STDOUT $fmt, @fields );
    printf(STDOUT "$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,.*\#,,;

        printf(STDOUT
               $fmt                 ,
               $line++              ,
               $author{$rev}        ,
               $change{$rev}        ,
               $revno, shift(@text) );
    }
}