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

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

#use POSIX qw( :sys_stat_h );

my ($exec, $ext) = ('/afs/athena/project/gnu/bin/g', '');
my $rlog = $exec . 'rlog' . $ext;
my $rcs =  $exec . 'rcs'  . $ext;
my $ci =   $exec . 'ci'   . $ext;
my $co =   $exec . 'co'   . $ext;

my $insert_prefix = '|> ';

select(STDERR);
autoflush STDERR 1;

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

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

$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);
  ($flag eq '-y') && ($yesyesyes=1, next);
  die "usage: $0 [-v] [-n] [-y] [ directory [ directory ... ]]\n";
}

@root = @ARGV;
# /mit/olcdev/highlander/src /source/athena/bin/olc.dev
# /mit/olcdev/src /mit/olcdev/olxx/olta/src /mit/opssrc/olc

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, @_ );
  return $yesyesyes if $yesyesyes;
  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->{'locker'})
	&& die "$0: parse error: duplicate 'locks:'";
      $data->{'lock'} = {};  $data->{'locker'} = {};
      while (($_ = <$fd>) && /^\s+/) {
	my ($who, $rev) = split(/:\s+/, $', 2);	#'
	chop $rev;
	$data->{'lock'}->{$who} = $rev;
	$data->{'locker'}->{$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) { 
    for $minor (minors $major, $root) {
      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) = @_;
  $archive || return '';
  my $l = length($insert_prefix);
  join("", map (substr($_, 0, $l) eq $insert_prefix ? substr($_,$l)."\n" : '',
		split(/\n/, $archive)) );
}
# convert a "working" comment to an "archive" comment
sub working_to_archive {
  my ($working) = @_;
  $working || return '';
  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+;//;
  splice(@data, 1,1) 
    if $data[1] && ($data[1] =~ /^branches:(\s+[\d\.]+;)+\s*$/);
  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";

  my $rev1 = revision( $revdata[0],$revdata[1],$revdata[2] );
  my $rev2 = revision( $revdata[3],$revdata[4],$revdata[5] );
  my $rev1w = useful( archive_to_working( $rev1 ));
     $rev1 = useful( $rev1 );
     $rev2 = useful( $rev2 );

  ($rev1w eq $rev2) || ($rev1 eq $rev2);
}

# add REV1 of FILE1 as REV2 to FILE2, with comment COMMENT.
# will first unlock revision CUR_LOCK and lock revision REV2_LOCK of FILE2.
# REV2_LOCKER currently has REV2_LOCK locked in RCS.
sub insert_tab_into_slot {
  my ($rev1, $file1, $rev2, $file2, $cur_lock, $rev2_lock, $rev2_locker,
      $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, "-M", @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!  (-f forces deposit even if the file is unchanged)
    if ($dryrun) { print STDERR "WOULD do: check in $file2:$rev2\n"; }
    else         { system $ci, "-m$comment", "-f$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'}\n> $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.
	  $prefix = "$major.$minor";
	  print "   revision $major.$minor matches\n" if $verbose;
	} elsif (! revision $major, $minor, $primary_branch) {
	  # the revision is missing in primary; try inserting it.
	  print "   revision $major.$minor is empty in primary\n" if $verbose;
	  my $comment =
	    insert_tab_into_slot("$major.$minor", $rlog[1]{'file'},
				 "$major.$minor", $rlog[0]{'file'},
				 $rlog[0]{'lock'}{getpwuid($<)},
				 $prefix,  $rlog[0]{'locker'}{$prefix},
				 revision ($major, $minor, $other_branch));
	  insert_revision ($comment, $major, $minor, $primary_branch);
	  $prefix = "$major.$minor";
	} 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) {
	    if (revisions_eq($fmajor, 1,     $fork,
			     $major, $minor, $other_branch)) {
	      @archive = ($prefix, $fmajor, 1);
	      $prefix = join('.', @archive);
	      print "   revision $major.$minor matches $prefix\n" if $verbose;
	    }
	  }
	  # if @archive is empty, a branch doesn't exist; let's create one.
	  unless (@archive) {
	    print "   revision $major.$minor doesn't match\n" if $verbose;
	    my $comment =
	      insert_tab_into_slot("$major.$minor",        $rlog[1]{'file'},
				   "$prefix.$next_fork.1", $rlog[0]{'file'},
				   $rlog[0]{'lock'}{getpwuid($<)},
				   $prefix,  $rlog[0]{'locker'}{$prefix},
				   revision ($major, $minor, $other_branch));
	    insert_revision ($comment, $next_fork, 1,
			     insert_branch ("$prefix.", $rlog[0]));
	    @archive = ($prefix, $next_fork, 1);
	    $prefix = join('.', @archive) if $comment;
	  }
	}
      } else {
	# archive mode; go to the next archive revision.
	$archive[2]++;
	my $archive_branch = branch "$archive[0].", $rlog[0];

	# compare archive revision with working tree
	if (revisions_eq($archive[1], $archive[2], $archive_branch,
			 $major,      $minor,      $other_branch)) {
	  # match; just mark the place and continue.
	  $prefix = join('.', @archive);
	  print "   revision $major.$minor matches $prefix\n" if $verbose;
	} elsif (! revision $archive[1], $archive[2], $archive_branch) {
	  # the revision is missing in archive; try inserting it.
	  my $ixpref = join('.', @archive);
	  print "   revision $major.$minor maps onto empty $ixpref (archive)\n"
	    if $verbose;
	  my $comment =
	    insert_tab_into_slot("$major.$minor", $rlog[1]{'file'},
				 $ixpref,         $rlog[0]{'file'},
				 $rlog[0]{'lock'}{getpwuid($<)},
				 $prefix,  $rlog[0]{'locker'}{$prefix},
				 revision ($major, $minor, $other_branch));
	  insert_revision($comment, $archive[1], $archive[2], $archive_branch);
	  $prefix = $ixpref if $comment;;
	} else {
	  # archive mismatch!  Try checking if it branched off again.
	  my $fork = branch "$prefix.", $rlog[0];
	  my @fmajors = majors $fork;
	  my $next_fork = ($fmajors[$#fmajors] || 0) + 1;
	  my($fmajor, @narchive);
	  for $fmajor (@fmajors) {
	    if (revisions_eq($fmajor, 1,     $fork,
			     $major, $minor, $other_branch)) {
	      @narchive = ($prefix, $fmajor, 1);
	      $prefix = join('.', @narchive);
	      print "   revision $major.$minor matches $prefix\n" if $verbose;
	    }
	  }
	  # if @narchive is empty, a branch doesn't exist; let's create one.
	  if (@narchive) { @archive = @narchive; }
	  else {
	    print "   revision $major.$minor doesn't match fork\n" if $verbose;
	    my $comment =
	      insert_tab_into_slot("$major.$minor",        $rlog[1]{'file'},
				   "$prefix.$next_fork.1", $rlog[0]{'file'},
				   $rlog[0]{'lock'}{getpwuid($<)},
				   $prefix,  $rlog[0]{'locker'}{$prefix},
				   revision ($major, $minor, $other_branch));
	    insert_revision ($comment, $next_fork, 1,
			     insert_branch ("$prefix.", $rlog[0]));
	    @archive = ($prefix, $next_fork, 1);
	    $prefix = join('.', @archive) if $comment;
	  }
	}
      }
    }
  }
  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);