#!/afs/athena/contrib/perl5/p -w

use strict;
use FileHandle;
use DirHandle;
use POSIX qw( :sys_stat_h );
use File::Copy ();
use File::Basename ();
use File::Path ();
use Term::ReadKey;
use lib '/mit/olcdev/highlander';
use File::MultiFind;

die "You probably shouldn't be running this.  Try rlog-merge.pl...\naborting";

my $rlog = '/afs/athena/project/gnu/bin/grlog';
my $rcs =  '/afs/athena/project/gnu/bin/grcs';
my $ci =   '/afs/athena/project/gnu/bin/gci';
my $co =   '/afs/athena/project/gnu/bin/gco';

my $insert_prefix = '|> ';

select(STDERR);
autoflush STDERR 1;

use lib '/mit/bert/PERL';
use DataDump;

use vars qw( @root $force $writeable $verbose $dryrun );

$0 =~ s@.*/@@g;

while (defined($ARGV[0]) && ($ARGV[0] =~ /^-/)) {
  my $flag = shift;
  ($flag eq '-w') && ($writeable=1, next);
  ($flag eq '-v') && ($verbose=1,   next);
  ($flag eq '-n') && ($dryrun=1,    next);
  die "usage: $0 [-v] [-w] [-n] [ directory [ directory ... ]]\n";
}

@root = @ARGV;
$root[0] ||= '/mit/olcdev/highlander/src';
$root[1] ||= '/source/athena/bin/olc.dev';
$root[2] ||= '/mit/olcdev/highlander/src-olta';

sub rcs_file {
  my ($file) = $_[0];
  $file =~ s%$%,v%;
  -e $file && return $file;
  ($file = $_[0]) =~ s%(/[^/]+)$%/RCS$1,v%;
  -e $file && $file;
}
sub rcs_file_name {
  my ($file) = $_[0];
  $file =~ s%(/[^/]+)$%/RCS$1,v%;
  $file;
}

sub y_or_n {
  my %ret = ( 'y' => 1, 'Y' => 1, 'n' => 0, 'N' => 0, @_ );
  my $c;
  ReadMode 3;
  while ($c = ReadKey 0) {
    exists $ret{$c} && last;
    print "\007";
  }
  ReadMode 0;
  $ret{$c};
}

sub rlog_header {
  my ($fd, $data) = @_;

  while (<$fd>) {
    # parse various interesting header fields.
    /^head:\s+(\S*)/i 		&& ($data->{'head'} = $1, next);
    /^branch:\s+(\S*)/i		&& ($data->{'branch'} = $1, next);

    # if we run into 'locks:', the following lines will contain lock data.
    /^locks: /i   && do {
      (exists $data->{'lock'} || exists $data->{'locked'})
	&& die "$0: parse error: duplicate 'locks:'";
      $data->{'lock'} = {};  $data->{'locked'} = {};
      while (($_ = <$fd>) && /^\s+/) {
	my ($who, $rev) = split(/:\s+/, $', 2);	#'
	chop $rev;
	$data->{'lock'}->{$who} = $rev;
	$data->{'locked'}->{$rev} = $who;
      }
      # $_ now contains the first *non-matching* line.
      $_ ? redo : last;   # redo is like next but w/o re-reading the line!
    };

    # 'symbolic names:' is followed by the list of symbolic revision names.
    /^symbolic names:/i   && do {
      exists $data->{'symbol'} && die "$0: parse error: duplicate 'symb...:'";
      $data->{'symbol'} = {};
      while (($_ = <$fd>) && /^\s+/) {
	my ($tag, $rev) = split(/:\s+/, $', 2);	#'
	chop $rev;
	$data->{'symbol'}->{$tag} = $rev;
      }
      # $_ now contains the first *non-matching* line
      $_ ? redo : last;   # redo is like next but w/o re-reading the line!
    };

    # description must be the last header field, and end with a line of -'s.
    /^description:/i   && do {
      exists $data->{'desc'}&& die "$0: parse error: duplicate 'description:'";
      $data->{'desc'} = '';
      while (($_ = <$fd>) && !/^(\-+|\=+)$/) {
	$data->{'desc'} .= $_;
      }
      last;
    };

    # if we run into a separator, we managed to miss the description...
    /^(\-+|\=+)$/ && die "$0: parse error: unexpected end of header";
  }

  exists $data->{'head'}   || die "$0: parse error: missing 'head:'";
  exists $data->{'lock'}   || die "$0: parse error: missing 'locks:'";
  exists $data->{'symbol'} || die "$0: parse error: missing 'symbolic names:'";
  exists $data->{'desc'}   || die "$0: parse error: missing 'description:'";
  $data;
}

sub rlog_entry {
  my ($fd, $data) = @_;
  return unless $fd->fileno;

  $_ = <$fd> || return;

  /^revision\s+([\d\.]+)/ || die "$0: parse error: 'revision' expected";
  my ($revision, $entry) = ($1, '');
  my ($branch, $major, $minor) = ($revision =~ /^(.*\.)?(\d+)\.(\d+)$/);
  defined $major || (die "$0: invalid revision string '$revision'");

  while (($_ = <$fd>) && !/^(\-+|\=+)$/) {
    $entry .= $_;
  }

  # create any missing parts of the tree and store the data.
  $branch					||= '';
  $data->{'tree'}				||= {};
  $data->{'tree'}->{$branch}			||= [];
  $data->{'tree'}->{$branch}[$major]		||= [];
  $data->{'tree'}->{$branch}[$major][$minor]	||= $entry;

  ($branch, $major, $minor);
}

sub digestify_rlog {
  my ($file) = @_;
  my $RLOG = new FileHandle "$rlog $file |";
  my ($branch, $major, $minor);

  my $data = { 'file' => $file };

  rlog_header($RLOG, $data);
  while (($branch,$major,$minor) = rlog_entry($RLOG, $data)) {
    print STDERR "$file -- branch '$branch' ver $major.$minor\n" if $verbose;
  }
  $data;
}

sub branch ($$) {
  my ($branch, $data) = @_;
  return undef unless ($data && $data->{'tree'});
  $data->{'tree'}->{$branch || ''};	# this may be undef, we don't care
}
sub revision ($$$) {
  my ($major, $minor, $root) = @_;
  return undef unless ($root && $root->[$major]);
  $root->[$major][$minor];		# this may be undef, we don't care
}
sub majors ($)  { 0 .. $#{ $_[0] }; }
sub minors ($$) { 0 .. $#{ $_[1]->[$_[0]] || [] }; }

sub insert_revision ($$$$) {
  my ($comment, $major, $minor, $root) = @_;
  # create any missing parts of the tree and store the data.
  $root->[$major]		||= [];
  $root->[$major][$minor]	  = $comment;
}
sub insert_branch ($$) {
  my ($branch, $data) = @_;
  # create any missing parts of the tree.
  $data->{'tree'}				||= {};
  $data->{'tree'}->{$branch || ''}		||= [];
}

sub revisions_of_branch {
  my ($root, $prefix, $postfix) = @_;
  defined $prefix  || ($prefix = '');
  defined $postfix || ($postfix = '');
  my ($major, $minor, @revs);

  for $major (majors $root) { 
    print "ROB: maj $major\n";
    for $minor (minors $major, $root) {
      print "ROB: maj $major min $minor\n";
      push @revs, "$prefix$major.$minor$postfix"
	if revision $major, $minor, $root;
    }
  }
  @revs;
}

# convert an "archive" comment to a "working" comment
sub archive_to_working ($) {
  my ($archive) = @_;
  join("", map (/^$insert_prefix/ ? $' : '', split(/\n/, $archive)));  #'
}
# convert a "working" comment to an "archive" comment
sub working_to_archive {
  my ($working) = @_;
  join("", map ("$insert_prefix$_\n", split(/\n/, $working)));
}

# remove any non-useful data from the version comments
sub useful ($) {
  return '' unless defined($_[0]) && $_[0];
  my @data = split(/\n/, $_[0]);
  $data[0] =~ s/\s+state:\s+\w+;//;
  join("\n", @data);
}

# compare two working revisions, or an archive and a working revision
sub revisions_eq {
  my (@revdata) = @_;
  scalar(@revdata) == 6 || die "$0: invalid call to revisions_eq";
  ( useful( archive_to_working(revision( $revdata[0],$revdata[1],$revdata[2])))
    eq useful( revision( $revdata[3],$revdata[4],$revdata[5] )) )
    || ( useful( revision( $revdata[0],$revdata[1],$revdata[2] ))
	 eq useful( revision( $revdata[3],$revdata[4],$revdata[5] )) );
}

# add REV1 of FILE1 as REV2 to FILE2, with comment COMMENT.
# will first unlock revision CUR_LOCK and lock revision REV2_LOCK of FILE2.
sub insert_tab_into_slot {
  my ($rev1, $file1, $rev2, $file2, $cur_lock, $rev2_lock, $comment) = @_;
  $comment = working_to_archive($comment);

  print "Add revision $rev1 of $file1:\n${comment}as revision $rev2 of $file2?"
    . " (y/n)\n";
  if (y_or_n) {
    # move the original file out of the way.
    my $tmpfile = "$file2.data0000";
    $tmpfile++ while -e $tmpfile;
    if ($dryrun) { print STDERR "WOULD do: rename $file2 to $tmpfile\n"; }
    else         { rename $file2, $tmpfile; }

    # unlock revision locked by this user.
    my @unlock = ();
    if ($cur_lock) {
      if ($dryrun) { print STDERR "WOULD do: unlock $file2:$cur_lock\n"; }
      else         { @unlock = ("-u$cur_lock"); }
    }

    # lock the `parent' revision of the revision to be checked in.
    if ($dryrun) { print STDERR "WOULD do: lock $file2:$rev2_lock\n"; }
    else         { system $rcs, @unlock, "-l$rev2_lock", $file2; }

    # dump the revision we are inserting into a file.
    if ($dryrun) { print STDERR "WOULD do: copy $file1:$rev1 to $file2\n"; }
    else {
      my $old_rev = new FileHandle "$co -p$rev1 $file1 |";
      File::Copy::copy($old_rev, $file2);
    }

    # add a header to the comment.
    $comment =
      "$file1, revision $rev1\n(archived for historic purposes)\n$comment";

    # check in the file!
    if ($dryrun) { print STDERR "WOULD do: check in $file2:$rev2\n"; }
    else         { system $ci, "-m$comment", "-r$rev2", $file2; }

    # relock revision previously locked by this user
    if ($cur_lock) {
      if ($dryrun) { print STDERR "WOULD do: re-lock $file2:$cur_lock\n"; }
      else         { system $rcs, "-l$cur_lock", $file2; }
    }

    # move the original file back into the way.
    if ($dryrun) { print STDERR "WOULD do: rename $tmpfile to $file2\n"; }
    else         { rename $tmpfile, $file2; }

    "[no real data here yet]\n$comment";
  } else { undef; }
}

sub do_comparison {
  my (@rlog) = @_;

  my (@nonempty) = grep($_, keys %{$rlog[1]->{'tree'}});
  if (@nonempty) {
    # The second tree has non-'' branches, which will be ignored/lost.
    my $revs = join (",  ",
		     map (revisions_of_branch( branch($_,$rlog[1]), $_ ),
			  @nonempty));
    print <<"EndOfWarning";
warning: $rlog[1]->{'file'} has branches other than the main.
         The following revisions will be ignored:
          $revs
Continue anyway? (y/n)
EndOfWarning
    die "User-requested abort" unless (y_or_n);
  }

  my $primary_branch = branch '', $rlog[0];
  my $other_branch =   branch '', $rlog[1];
  print "$rlog[0]->{'file'} and $rlog[1]->{'file'}:\n";

  my(@archive, $major, $minor);
  my($prefix) = '1.1';

  # go through all existing trees.
  for $major (majors $other_branch) {
    for $minor (minors $major, $other_branch) {
      revision $major, $minor, $other_branch || next;

      if (! @archive) {
	# not searching any archive branch; try main tree.
	if (revisions_eq($major, $minor, $primary_branch,
			    $major, $minor, $other_branch)) {
	  # match; just mark the place and continue.
	  print "   revision $major.$minor matches\n" if $verbose;
	  $prefix = "$major.$minor";
	} elsif (! revision $major, $minor, $primary_branch) {
	  # the revision is missing in primary; try inserting it.
	  my $comment =
	    insert_tab_into_slot("$major.$minor", $rlog[1]{'file'},
				 "$major.$minor", $rlog[0]{'file'},
				 $rlog[0]{'lock'}{getpwuid($<)}, $prefix,
				 revision ($major, $minor, $other_branch));
	  insert_revision ($comment, $major, $minor, $primary_branch);
	} else {
	  # mismatch!  Try checking if it branched off.
	  my $fork = branch "$prefix.", $rlog[0];
	  my @fmajors = majors $fork;
	  my $next_fork = ($fmajors[$#fmajors] || 0) + 1;
	  my($fmajor, @fver);
	  for $fmajor (@fmajors) {
	    @archive = ($prefix, $fmajor,1)
	      if revisions_eq($fmajor, 1,     $fork,
			      $major, $minor, $other_branch);
	  }
	  # if @archive is empty, a branch doesn't exist; let's create one.
	  unless (@archive) {
	    my $comment =
	      insert_tab_into_slot("$major.$minor",        $rlog[1]{'file'},
				   "$prefix.$next_fork.1", $rlog[0]{'file'},
				   $rlog[0]{'lock'}{getpwuid($<)}, $prefix,
				   revision ($major, $minor, $other_branch));
	    insert_revision ($comment, $next_fork, 1,
			     insert_branch ("$prefix.", $rlog[0]));
	    @archive = ($prefix, $next_fork, 1);
	  }
	}
      }
    }
  }
  print "\n";
}

sub compare_rcs {
  my ($primary, @others) = @File::MultiFind::names;
  my ($primary_rcs, @others_rcs, $primary_data, $other, $other_data);

  # does the primary have an RCS tree?
  if ($primary_rcs = rcs_file($primary)) {
    undef $primary_data;

    # go through all other trees
    for $other (@others) {
      # don't bother if there is no RCS file in this tree
      rcs_file($other) || next;

      # if we haven't yet, extract RCS log data for primary.
      $primary_data = digestify_rlog($primary) unless $primary_data;

      $other_data = digestify_rlog($other);
      do_comparison($primary_data, $other_data);
    }
  } else {
    # no RCS tree for primary
    $primary_rcs = rcs_file_name($primary);

    # if not, check if any of the others do.
    if (@others_rcs = grep ($_, map (rcs_file($_), @others))) {

      # 'transplant' the RCS tree?
      print "Missing RCS file for $primary\n";      
      if ($writeable) {
	print "Copy $others_rcs[0]\n  to $primary_rcs? (y/n)\n";
	if (y_or_n) {
	  if ($dryrun) {
	    print STDERR "WOULD do: create "
	      . File::Basename::dirname($primary_rcs) . "\n";
	    print STDERR "WOULD do: copy $others_rcs[0] -> $primary_rcs\n";
	    print STDERR "WOULD do: re-start comparing RCS files\n";
	  } else {
	    File::Path::mkpath(File::Basename::dirname($primary_rcs), 1, 0755);
	    File::Copy::copy($others_rcs[0], $primary_rcs);
	    goto &compare_rcs;		# try again...
	  }
	}
      }

    } else {
      # no RCS files in any trees; just print a message.
      warn "No RCS file for .$File::MultiFind::relative (ignoring)\n";
    }
  }
}

sub wanted {
  prune if ($_ eq 'RCS');
  return if $File::MultiFind::directories || /~$/;;

  if (! $File::MultiFind::allnames[0]) {
    warn ".$File::MultiFind::relative doesn't exist in primary tree "
      . "(ignoring)\n";
    return;
  }

  compare_rcs();
}

$File::MultiFind::dont_use_nlink=1;
$File::MultiFind::Tree::descend_links=1;

multifind(\&wanted, @root);