#!/usr/bin/perl

### Copyright and license notice

# Copyright (C) 2002 WorldWinner.com, Inc.

# 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; either version 2 of the License, or
# (at your option) any later version.

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

### Description of the script

# This script displays a condensed summary of changes between two
# versions of a module in a CVS repository.  It takes all the same
# arguments as "cvs rdiff" (except you shouldn't specify "-c", "-u",
# "-s" or "-t").  See the usage message below for additional usage
# information.

# The script displays a list of added files (with their current
# revision numbers as of the target version of the diff), a list of
# removed files, and a summary of each change which modified files,
# including the date, author, description, and list of modified files.

# Changes are displayed in chronological order; specify "--reverse" to
# reverse them.

# Dates are displayed in local time unless you specify "--gmt".

# The script assumes that the two versions of the module being
# compared are on the same branch.  I haven't made any effort to make
# this work for module versions on different branches; that doesn't
# usually make much sense anyway -- if the versions are on different
# branches, how can you say what changes are between the two versions?

# Search below for "### Configuration" for things you might want to
# modify.

# This script is maintained by Jonathan Kamens
# <jik@kamens.brookline.ma.us>.  Please send me bug reports, fixes,
# comments and enhancements!

use strict;
use warnings;
use Getopt::Long;
use File::Basename;
use File::Temp qw(tempfile tempdir);
use IO::Handle;
use Text::Wrap;
use Time::Local;
use POSIX qw(strftime);

### Configuration

# Sometimes people check in changes separately rather than all at
# once.  If they do this, the timestamps on the changes may not match
# up exactly, so this script may not, by default, consider them a
# single change.  If you want such changes to be merged into a single
# change in the output of this script, then set this variable to the
# threshold of how many seconds apart to allow such changes.  The
# timestamp displayed for such a merge change is the timestamp of the
# *last* change in the set.  By default, changes by the same author
# with the same description that do have gaps of less than 60 seconds
# between them are merged.  Set this variable to 0 to disable merging
# completely.
my($merge_threshold) = 60;

# If you want changes in reverse chronological order by default, set
# this.
my($opt_reverse) = 0;

# If you want debugging enabled by default, set this to the debug
# level (higher levels mean more debugging info.
my($opt_debug) = 0;

# If you want dates to display in GMT by default, set this to true.
my($opt_gmt) = 0;

### End Configuration.

# You should not need to modify anything below unless you are fixing
# bugs or adding enhancements to the script (please send me your
# patches!).

my($whoami) = basename $0;
my($usage) = 
    "Usage: $whoami [cvs rdiff options] [--help] [--debug ...]
	[--[no]reverse] [--[no]gmt] [--sandbox-root=dir|--checkout]
	[--merge-threshold=#] module ...

    Specify --reverse to display changes in reverse chronological
    order.

    Checked-out modules will be searched for in the specified sandbox
    root, or in your home directory if the sandbox root isn't
    specified.  If a module is not found, it will be checked out in a
    temporary directory.  To force a checkout regardless of what's in
    your home directory, specify \"--checkout\".

    Specify --merge-threshold=# to indicate the maximum number of
    seconds between nearby changes which should be merged into a
    single change in the output.\n";

# %opts - most cvs rdiff flags
# @cvs_rev_opts - cvs rdiff "-r" -and "-D" flags
my(%opts, @cvs_rev_opts, $opt_checkout, $opt_sandbox, $opt_help);

# All "cvs rdiff" flags except the ones for specifying revision ranges
my(@cvs_flags) = ('f', 'l', 'R', 'c', 'u', 's', 't');

# "cvs rdiff" flags for specifying revision ranges.  We track these
# specially because (a) order is important and (b) the user can only
# specify up to two of them.
my(@cvs_rev_flags) = ('r', 'D');

# "cvs rdiff" flags we don't want the user to specify
my(@cvs_bad_flags) = ('c', 'u', 's', 't');

Getopt::Long::Configure('bundling');

die $usage if (! GetOptions(map(($_ => \$opts{$_}), @cvs_flags),
			    map(("$_=s@" => \&cvs_rev_opt), @cvs_rev_flags),
			    'reverse!' => \$opt_reverse,
			    'gmt!' => \$opt_gmt,
			    'checkout' => \$opt_checkout,
			    'sandbox-root=s' => \$opt_sandbox,
			    'debug+' => \$opt_debug,
			    'help' => \$opt_help,
			    'merge-threshold=i' => \$merge_threshold));

sub cvs_rev_opt {
    my($name, $val) = @_;

    push(@cvs_rev_opts, "-$name$val");
}

if ($opt_help) {
    print $usage;
    exit;
}

if ($opt_sandbox && $opt_checkout) {
    die "$whoami: Can't specify both --sandbox-root and --checkout\n$usage";
}
elsif (! ($opt_sandbox || $opt_checkout)) {
    $opt_sandbox = $ENV{'HOME'};
}

my(@cvs_modules) = @ARGV;
my(@cvs_command) = ('cvs', '-q', 'rdiff', '-s', &rdiff_options(),
		    @cvs_modules);

# Figure out the options to pass to "cvs rdiff" by looking at %opts
# and @cvs_rev_opts.  Make sure that forbidden arguments weren't
# specified and that the user didn't specify too many or too few
# revision arguments.
sub rdiff_options {
    my(@options);
    my($gotrev);

    foreach my $flag (@cvs_bad_flags) {
	die "$whoami: Don't specify -$flag\n$usage" if ($opts{$flag});
    }

    if (! @cvs_rev_opts) {
	die "$whoami: Must specify at least one -r or -D argument\n$usage";
    }
    if (@cvs_rev_opts > 2) {
	die "$whoami: Can't specify more than two -r/-D arguments\n$usage";
    }

    foreach my $flag (@cvs_flags) {
	push(@options, "-$flag") if ($opts{$flag});
    }

    (@options, @cvs_rev_opts);
}

my($cvs_out, $cvs_err) = &system_save_stderr(@cvs_command);

# Note that %changed_from contains the revision *before* the first one
# we want to display.
my(@new_files, @removed_files, @changed_files, %changed_from, %changed_to);

while (<$cvs_out>) {
    if (/^File (.*) is new; current revision (\S+)/) {
	push(@new_files, $1);
	$changed_to{$1} = $2;
	warn "$1 is new at $2\n" if ($opt_debug > 1);
    }
    elsif (/^File (.*) is removed;/) {
	push(@removed_files, $1);
	warn "$1 was removed\n" if ($opt_debug > 1);
    }
    elsif (/^File (.*) changed from revision (\S+) to (\S+)/) {
	my($file, $from, $to) = ($1, $2, $3);

	push(@changed_files, $file);

	# Ugh!  Yucky special cases!
	if ($from eq '1.1.1.1') {
	    # XXX I'm not sure how to handle the case of multiple
	    # vendor branches.  I think it's unlikely enough that it's
	    # not worth worrying about.  If you encounter it and can
	    # figure out a good way to deal with it here, please let
	    # me know.
	    $from = '1.1';
	}

	$changed_from{$1} = $from;
	$changed_to{$1} = $to;
	warn "$1 was changed from $2 to $3\n" if ($opt_debug > 1);
    }
    else {
	die "$whoami: Unexpected output from \"@cvs_command\": $_";
    }
}

my($cvs_errors) = 0;

if (! close($cvs_out)) {
    $cvs_errors++;
    warn "$whoami: \"@cvs_command\" failed\n";
}

while (<$cvs_err>) {
    warn "$whoami: Error from \"@cvs_command\": $_";
    $cvs_errors++;
}

close($cvs_err);

exit(1) if ($cvs_errors);

my($tempdir);

foreach my $module (@cvs_modules) {
    if ($opt_sandbox && -d "$opt_sandbox/$module") {
	chdir($opt_sandbox) || die "$whoami: chdir($opt_sandbox): $!\n";
    }
    else {
	if (! $tempdir) {
	    $tempdir = tempdir(CLEANUP => 1);
	}
	chdir($tempdir) || die "$whoami: chdir($tempdir): $!\n";
	system('cvs', '-Q', 'checkout', $module) &&
	    die "$whoami: cvs -Q checkout $module failed\n";
    }
}

my(%changes);

foreach my $file (@changed_files) {
    &parse_log($file, $changed_from{$file}, $changed_to{$file});
}

&merge_adjacent_changes();

if (@new_files) {
    print wrap('Added files: ', ' ', 
	       join(' ', map($_ . ':' . $changed_to{$_}, @new_files))), "\n\n";
}

if (@removed_files) {
    print wrap('Removed files: ', ' ', "@removed_files"), "\n\n";
}

foreach my $change ($opt_reverse ?
		    (reverse sort keys %changes) : (sort keys %changes)) {
    my(@files) = @{$changes{$change}};
    my($author) = &change_author($change);
    my($date);
    my($text) = &change_text($change);

    $text =~ s/\n/\n  /g;

    if ($opt_gmt) {
	$date = &change_date($change) . ' GMT';
    }
    else {
	$date = strftime("%Y/%m/%d %H:%M:%S %Z",
			 localtime(&change_time($change)));
    }

    print "Date: $date\n";
    print "Author: $author\n";
    print "Description:\n  $text\n";
    print wrap('Affected files: ', '  ', "@files"), "\n\n";
}

exit;

# Start a command whose stdout we want to read using a list of
# arguments.
sub system_args {
    my(@cmd) = @_;
    my($stdout_fh);
    my($pid) = open($stdout_fh, "-|");

    if (! defined($pid)) {
	die "$whoami: fork: $!\n";
    }
    elsif (! $pid) {
	warn "Executing \"@cmd\" in a subprocess\n" if ($opt_debug);
	exec(@cmd);
	die "$whoami: exec(@cmd): $!\n";
    }

    return($stdout_fh);
}

# Start a command whose stdout we want to read, with stderr saved into
# a temporary file.  Return the stdout and stderr file handles.  We
# use this rather than open2 or anything like that because we don't
# want to read stderr until we're done reading everything else, so
# stderr may block if we don't put it into a temporary file.
sub system_save_stderr {
    my(@cmd) = @_;
    my($stderr_fh) = tempfile();
    my($stdout_fh);
    my($pid) = open($stdout_fh, "-|");

    if (! defined($pid)) {
	die "$whoami: fork: $!\n";
    }
    elsif (! $pid) {
	warn "Executing \"@cmd\" in a subprocess\n" if ($opt_debug);
	open(STDERR, '>&' . $stderr_fh->fileno) 
	    || die "$whoami: reopen STDERR: $!\n";
	exec(@cmd);
	die "$whoami: exec(@cmd): $!\n";
    }
    else {
	# This is necessary to make Perl realize that another process
	# may have written data to it.
	seek($stderr_fh, 0, 0);
	return($stdout_fh, $stderr_fh);
    }
}

# Retrieve the log for a file, parse it, and put the resulting
# information into the %changes hash.
#
#   date: <date>; author: <author>;
#   <description>
# 
# Takes two or three arguments.  If three, they are the file name, the
# starting revision, and the ending revision, and the starting
# revision is *not* included in the returned list.  If only two
# arguments, then the ending revision is omitted, and only the one
# specified revision is retrieved and parsed.
#
# This function needs to be smart about the fact that text that looks
# like a revision description may be embedded inside a revision
# description.  To deal with this possibility, the returned log is
# split at apparent revision boundaries and examined for consistency,
# and if any inconsistencies are found, we fall back on retrieving the
# revision descriptions one at a time, which is slower, but guaranteed
# to be accurate.

sub parse_log {
    local($/) = "\n----------------------------\nrevision ";
    local($_);
    my($file, $from, $to) = @_;
    my($range) = ($to ? "-r$from:$to" : "-r$from");
    my($from_prefix, $to_prefix, $from_tail, $to_tail, $count_prefix,
       $count_start, @expected_revs, @cmd, $fh, @chunks, @remaining_revs);

    ($from_prefix, $from_tail) = &parse_rev($from);

    if ($to) {
	($to_prefix, $to_tail) = &parse_rev($to);
	if ($from_prefix eq $to_prefix) {
	    # Great, that's the easy case, that means that both the
	    # from and to revisions are on the same branch
	    $count_prefix = $to_prefix;
	    $count_start = $from_tail;
	}
	elsif ((substr($to_prefix, 0, length($from_prefix)) eq $from_prefix) &&
	       ($to_prefix =~ tr/././) == (($from_prefix =~ tr/././) + 1)) {
	    $count_prefix = $to_prefix;
	    $count_start = 1;
	}
	else {
	    die(wrap("$whoami: ", '  ',
		     "Internal error: can't figure out how revisions " .
		     "$from and $to of $file are related") . "\n");
	}

	@expected_revs =
	    reverse map("$count_prefix$_", $count_start..$to_tail);
	push(@expected_revs, $from) if ($count_prefix ne $from_prefix);
    }

    @cmd = ('cvs', 'log', $range, $file);
    $fh = &system_args(@cmd);

    # Discard the start of the log
    <$fh>;

    while (<$fh>) {
	s,$/$,,;
	push(@chunks, $_);
    }

    close($fh) || die "$whoami: \"@cmd\" failed\n";

    return () if (! @chunks);

    $chunks[-1] =~ s/\n=+\n+$//;

    if (! @expected_revs) {
	$chunks[0] =~ s/^.*\n//;
	# If we're only supposed to be returning a single revision, and we
	# matched multiple revision markers, then we know it was because
	# they were inside that single revision entry, so we join them
	# together.
	push(@{$changes{&change_key(join($/, @chunks))}}, "$file:$from");
    }

    @remaining_revs = @expected_revs;

    for (@chunks) {
	if (! @remaining_revs || ! s/^([\d.]+)\n// || 
	    ($1 ne shift @remaining_revs)) {
	    pop @expected_revs;
	    map((&parse_log($file, $_)), @expected_revs);
	}
    }

    pop @chunks;
    pop @expected_revs;

    map(push(@{$changes{&change_key($_)}}, "$file:" . shift @expected_revs),
	@chunks);
}

# Takes a revision string and parses it into a prefix (everything up
# to and including the final dot) and a tail.  Dies if the revision
# string is in an invalid format.  Returns the prefix and the tail.

sub parse_rev {
    my($rev) = @_;

    die("$whoami: Internal error: bad revision \"$rev\"\n")
	if ($rev !~ /^((?:\d+\.)+)(\d+)$/);
    return($1, $2);
}

# Searches for changes with identical descriptions which occurred
# close together and merges them.

sub merge_adjacent_changes {
    my(%hashed);

    return if ($merge_threshold <= 0);

    foreach my $change (sort keys %changes) {
	my($text) = &change_text($change);
	my($author) = &change_author($change);
	my($new_time) = &change_time($change);

	if (my $prev = $hashed{$text}{$author}) {
	    my($old_time) = $hashed{$text}{$author}{time};
	    my($old_change) = $hashed{$text}{$author}{change};

	    if ($new_time - $old_time < $merge_threshold) {
		unshift(@{$changes{$change}}, @{$changes{$old_change}});
		delete $changes{$old_change};
	    }
	}
	$hashed{$text}{$author}{time} = $new_time;
	$hashed{$text}{$author}{change} = $change;
    }    
}

my(%change_keys, %change_dates, %change_times, %change_authors, %change_texts);

# Takes the "raw" change from the log and coerces it into a slightly
# friendlier format.  
sub change_key {
    local($_) = @_;
    my($orig) = @_;

    return $change_keys{$_} if (defined($change_keys{$_}));

    # This could all be merged into a single regexp, but I've split it
    # all out to make it clearer.  The performance penalty is minimal.

    # Strip everything on the first line after the author
    s/^(.*\s+author:\s+\S+;).*\n?/$1\n/;

    # Strip "branches:" lines
    s/^(.*\n)branches:.*\n?/$1/;

    # Strip blank lines at the beginning of the description
    s/^(.*\n)\n+/$1/;

    # Strip whitespace at the end of the description
    s/\s+$//;

    return($change_keys{$orig} = $_);
}

# Fetch the date of a change
sub change_date {
    local($_) = @_;
    return $change_dates{$_} if ($change_dates{$_});
    die "$whoami; Internal error: No date in change:\n$_\n"
	if (! /^date:\s+(\S[^;]+);/);
    return($change_dates{$_} = $1);
}

# Feetch time timestamp of a change
sub change_time {
    local($_) = @_;
    return $change_times{$_} if ($change_times{$_});
    return($change_times{$_} = &parse_date(&change_date($_)));
}

# Fetch the author of a change
sub change_author {
    local($_) = @_;
    return $change_authors{$_} if ($change_authors{$_});
    die "$whoami; Internal error: No author in change:\n$_\n"
	if (! /^date:\s+\S[^;]+;\s+author:\s+(\S[^;]+;)/);
    return($change_authors{$_} = $1);
}

# Fetch the descriptive text of a change, with all leading and
# trailing whitespace removed.  The text may have embedded newlines
# but won't end with one.
sub change_text {
    local($_) = @_;
    my($orig) = @_;
    return $change_texts{$_} if (defined($change_texts{$_}));
    die "$whoami; Internal error: No date in change:\n$_\n"
	if (! s/^date:.*\n?//);
    return($change_texts{$orig} = $_);
}

# Parse a date into a Unix timestamp
sub parse_date {
    local($_) = @_;
    my($year, $month, $day, $hour, $minute, $second);

    die "$whoami: Internal error: Unexpected date format: $_\n"
	if (! (($year, $month, $day, $hour, $minute, $second) =
	       m,^(\d{4})/(\d{2})/(\d{2}) (\d{2}):(\d{2}):(\d{2})$,));

    timegm($second, $minute, $hour, $day, $month-1, $year-1900);
}