#!/afs/sipb/project/perldev/p -w
#!/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 File::Find;

my @rcsbins = ('/afs/athena/project/gnu/bin/g', '/afs/athena/project/gnu/bin/',
	       '/usr/athena/bin/');

sub binpath {
  my ($name) = @_;
  my ($path, $exec, $ext);
  foreach $path (@rcsbins) {
    ($exec, $ext) = (ref($path) ? @$path : $path, '', '');
    -x "$exec$name$ext" && return "$exec$name$ext";
  }
  die "$name binary not found in PATH\n  giving up\n";
}

my $rlog =    binpath('rlog');
my $rcs =     binpath('rcs');
my $ci =      binpath('ci');
my $co =      binpath('co');
my $rcsdiff = binpath('rcsdiff');

select(STDERR);
autoflush STDERR 1;

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

use vars qw( $USER @root $force $verbose $dryrun $yesyesyes );
use vars qw( $secret $Comment_Log );
$USER = $ENV{'USER'} || $ENV{'LOGNAME'} || die("can't find username");


$0 =~ s@.*/@@g;
sub usage { die "usage: $0 [-v] [-s] directory [ directory ... ]\n"; }

while (defined($ARGV[0]) && ($ARGV[0] =~ /^-/)) {
  my $flag = shift;
  ($flag eq '-v') && ($verbose=1,   next);
  ($flag eq '-s') && ($secret=1,    next);
  # ($flag eq '-n') && ($dryrun=1,    next);
  usage;
}

(@root = @ARGV) || usage();

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

sub y_or_n {
  choose( 'y' => 1, 'Y' => 1, 'n' => 0, 'N' => 0, @_ );
}

sub choose {
  return $yesyesyes if $yesyesyes;
  my %ret = @_;
  my $c;
  ReadMode 3;
  while ($c = ReadKey 0) {
    exists $ret{$c} && last;
    print "\007";
  }
  ReadMode 0;
  $ret{$c};
}

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

  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 (defined($_ = <$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 'symbolic names:'";
      $data->{'symbol'} = {};
      while (defined($_ = <$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 (defined($_ = <$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;

  local($_) = scalar(<$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 (defined($_ = <$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, @opts) = @_;
  my $RLOG = new FileHandle "$rlog @opts $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;
}

sub status {
  local ($_) = @_;
  my ($S, $C);

  my ($rcsfile, $writable) = (rcs_file($_), -w);
  $S = ($writable ? 'writeable' : 'read-only') . ', ';

  if ($rcsfile) {
    my $rlog = digestify_rlog($_);
    my $locked = scalar(keys %{$rlog->{'lock'}});
    my $mine = exists $rlog->{'lock'}->{$USER};

    $S .= ($locked? ($mine? 'locked' : 'locked by someone else') : 'unlocked');

    $C = ($writable || $locked);
  } else {
    $S .= 'no RCS file';
    $C = $writable;
  }

  if (wantarray) { ($S, $C); } else { $S; }
}

sub do_diff {
  my $file = shift;
  my $def_opts = '-up';
  print "rcsdiff flags [$def_opts]? ";
  my ($opts) = scalar <STDIN>;
  chomp $opts;
  $opts ||= $def_opts;
  system("$rcsdiff $opts $file | less")
}

sub fmtlog { join('', @_[1..$#_], map ("  $_\n", split(/\n/, $_[0]))); }
sub lol2string {
  my ($lol, $op, $pre, $post, $sep) = @_;
  defined($lol) || return '';
  ref($lol)     || return &$op($lol, $pre, $post);
  join('', map(lol2string($lol->[$_], $op, "$pre$sep$_", $post, '.'),
	       0..$#$lol));
}
sub tree2string {
  my ($tree, $pre, $post) = @_;
  join('', map(lol2string($tree->{$_}, \&fmtlog, "$pre$_", $post, ''),
	       sort keys %$tree));
}

sub do_checkin {
  my ($file, $name) = @_;

  if (! system("$ci -u $file")) {
    # check-in succeeded.
    $Comment_Log->print(tree2string(digestify_rlog($file, '-r')->{'tree'},
				    "[$name ", "]\n"), "\n")
      if $Comment_Log;
  } else {
    # check-in failed (possibly due to a ^C).
    print "check-in failed!  continuing.\n";
    #exit 1 unless (y_or_n(), print("\n"))[0];
  }
}

my @deal_opts =('I' => 'checkin', 'O' => 'checkout', 'N' => '',
		'D'=>'diff', 'R'=>'rlog', 'L'=>'lock', 'U'=>'unlock');
push (@deal_opts, map(lc($_), @deal_opts));

sub deal {
  my ($file, $name, $status) = @_;

  while (1) {
    $status = status($file) unless defined $status; 
    print "$name: $status\n" .
      'checkIn/checkOut/Next;Lock/Unlock/Diff/Rlog {I,O,N,L,U,D,R}? ';
    undef $status;

    my $opt = choose(@deal_opts);
    print "\n";

    ($opt eq 'diff')     && (do_diff($file), next);
    ($opt eq 'rlog')     && (system("$rlog $file | less"), next);

    ($opt eq 'lock')     && (system("$rcs -l $file"), next);
    ($opt eq 'unlock')   && (system("$rcs -u $file"), next);

    ($opt eq 'checkout') && system("$co -u $file"); # co will ask if clobbering
    ($opt eq 'checkin')  && do_checkin($file, $name);
    last;  # user selected I, O or N; either way, we're done
  }
}

$secret || ($Comment_Log = new FileHandle ">> ci-comments.log")
  || die "Cannot append to ci-comments.log";

sub wanted {
  $File::Find::prune=1 if ($_ eq 'RCS');
  return if (/(?:~|\.bak)$/ || /^(?:TAGS|\.purify)/ || ! -f);
  # push(@file_list, $File::Find::name);

  my ($status, $change) = status($_);
  deal($_, $File::Find::name, $status) if $change;
  $Comment_Log->flush if $Comment_Log;
}

$File::Find::dont_use_nlink=1;
find(\&wanted, @root);

$Comment_Log->close;