#!/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;
use POSIX qw( getcwd );   # ...because Cwd::getcwd sucks with AFS

my ($exec, $ext) = ('/mit/gnu/bin/g', '');
my $rlog =    $exec . 'rlog'    . $ext;
my $co =      $exec . 'co'      . $ext;

my $cp =      $exec . 'cp'      . $ext;
my @cp = ($cp, '-dr');

select(STDERR);
autoflush STDERR 1;

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

use vars qw( $USER @root $verbose $dryrun $Cfg_File );
$USER = $ENV{'USER'} || $ENV{'LOGNAME'} || die("can't find username");
$Cfg_File = "./pick-up.conf";

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

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

use vars qw( $source $pickup @prune @prune_subtree @graft );
require $Cfg_File || die "Can't read the conf file! (try -f ?)\n  quitting";

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 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 (($_ = <$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;

  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 (($_ = <$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;
}

sub maybe ($&) {
  if ($dryrun) {
    warn "Would do: $_[0]\n" if $dryrun>0;
  } else {
    &{$_[1]};
  }
}

sub maybe_system { my (@S)=@_; maybe("@S", sub { system(@S) }); }
sub maybe_mkpath { my ($P)=@_; maybe("create $_[0]", sub {mkpath $P, 1, 0755})}
sub maybe_rmtree { my ($P)=@_; maybe("rm -rf $_[0]", sub {rmtree $P, 0, 0})}

sub graft {
  my ($dir, $from) = @_;
  my ($cwd) = getcwd;

  chdir $from || die "Can't cd to $from";
  graft_level($pickup, split(m@/@, $dir))
    || warn "No files/directories match $dir!\n";
  chdir $cwd  || warn "Can't cd back to $cwd (from top level)";
}

sub graft_level {
  my ($dest, $name, @deeper) = @_;
  my ($match, $e) = 0;

  foreach $e (glob $name) {
    if (@deeper) {
      next unless -d $e;

      my ($cwd) = getcwd;
      chdir $e || die "Can't cd to $e for @deeper";
      $match += graft_level("$dest/$name", @deeper);
      chdir $cwd || die "Can't cd back to $cwd";
    } else {
      maybe_mkpath($dest) unless -d $dest;
      maybe_system("@cp $e $dest");
      $match++;
    }
  }

  return $match;
}

sub checkoutable {
  local ($_) = shift;
  my ($name, $relative) = @_;

  scalar grep(($relative =~ /$_/), @prune)
    && do { warn "Skipping $name (pruned)\n"; return 0 };

  rcs_file($_) || do { warn "Skipping $name (no RCS file)\n"; return 0 };

  keys %{digestify_rlog($_)->{'lock'}} &&
    do { warn "Skipping $name (is locked)\n"; return 0 };

  (-w $_) && do { warn "Skipping $name (unlocked but writable)\n"; return 0 };

  return 1;
}

sub wanted {
  my $rel_dir = $File::Find::dir;
  $rel_dir =~ s@^\Q$source\E/?@@;
  my $rel_file = length($rel_dir) ? "$rel_dir/$_" : $_;

  $File::Find::prune=1 if ($_ eq 'RCS');
  if (scalar grep(($rel_file eq $_), @prune_subtree)) {
    $File::Find::prune=1;
    warn "Pruning descendants of $File::Find::name\n";
  }
  return if (/~$/ || ! -f);

  if (checkoutable($_, $File::Find::name, $rel_file)) {
    my $destdir = $pickup;
    $destdir .= '/' . $rel_dir if length($rel_dir);

    maybe_mkpath($destdir) unless -d $destdir;
    maybe_system("$co -kk -p $_ > $destdir/$_ 2>/dev/null");
  }
}

print "Removing previous pickup tree...\n";
maybe_rmtree($pickup) if -e $pickup;

print "Rebuilding pickup tree...\n";
$File::Find::dont_use_nlink=1;
find(\&wanted, $source);

print "Grafting subtrees...\n";
my $g;
foreach $g (@graft) {
  graft(@$g);
}

print "Changing file permissions...\n";
maybe_system("chmod -R ugo-w $pickup");

print "done!\n";