#!/bin/sh
exec perl -S -x -- "$0" "$@"
#!perl -w

use English;
# Unfortunately, contrary to the documentation, the connection between
# $_ and $ARG that the English module claims to establish is
# unreliable.  The problem seems to be due to strange interactions
# with "foreach" and may be dependent on the version of Perl.  It is
# best to avoid the use of $ARG.  The connection between the other
# special variables and their nice names probably works fine.

use strict;

use Getopt::Long;
use File::Find;
use JBW::Utils qw(&with_file_contents &bind_to_files);

my $JBW_CVS_Host = 'jbwcvs.macs.hw.ac.uk';
my $JBW_CVS_Area = "$JBW_CVS_Host:/jbw-cvs";
my $JBW_CVS_Main = "$JBW_CVS_Area/main";
#my $Church_CVS_Root = 'types.bu.edu:/cvsroot';
my $Church_CVS_Root = 'csa2.bu.edu:/research/church/fs/church-data/cvsroot';
my $JBW_BU_CVS_Root = 'csa2.bu.edu:/research/church/fs/church/jbw/cvsroot';

my $Built_In_CVS_Repository_Moves = <<EOF;
    osiris.cee.hw.ac.uk:/u1/staff/jbw/cvsroot => $JBW_CVS_Main
    selene.cee.hw.ac.uk:/u1/staff/jbw/cvsroot => $JBW_CVS_Main
    jbwcvs.cee.hw.ac.uk:/u1/staff/jbw/cvsroot => $JBW_CVS_Main
    osiris.cee.hw.ac.uk:/home/staff/jbw/cvsroot => $JBW_CVS_Main
    selene.cee.hw.ac.uk:/home/staff/jbw/cvsroot => $JBW_CVS_Main
    jbwcvs.cee.hw.ac.uk:/home/staff/jbw/cvsroot => $JBW_CVS_Main
    osiris.cee.hw.ac.uk:/jbw-cvs/main => $JBW_CVS_Main
    selene.cee.hw.ac.uk:/jbw-cvs/main => $JBW_CVS_Main
    jbwcvs.cee.hw.ac.uk:/jbw-cvs/main => $JBW_CVS_Main
    /users/staff/jbw/cvsroot => $JBW_CVS_Main
    hawaii.dcs.gla.ac.uk:/users/staff/jbw/cvsroot => $JBW_CVS_Main
    lroot\@wolf-home.cee.hw.ac.uk:/root/cvsroot => jbw\@$JBW_CVS_Main
    jbwcvs.cee.hw.ac.uk:/jbw-cvs/gc => $JBW_CVS_Area/gc
    jbwcvs.cee.hw.ac.uk:/jbw-cvs/share => $JBW_CVS_Area/share
    selene.cee.hw.ac.uk:/jbw-cvs/share => $JBW_CVS_Area/share
    jbwcvs.cee.hw.ac.uk:/u1/staff/jbw/cvs/share => $JBW_CVS_Area/share
    selene.cee.hw.ac.uk:/u1/staff/jbw/cvs/share => $JBW_CVS_Area/share
    jbwcvs.cee.hw.ac.uk:/home/staff/jbw/cvs/share => $JBW_CVS_Area/share
    selene.cee.hw.ac.uk:/home/staff/jbw/cvs/share => $JBW_CVS_Area/share
    jbwcvs.cee.hw.ac.uk:/jbw-cvs/alx => $JBW_CVS_Area/alx
    cs.bc.edu:/s1/users/church/cvsroot => $Church_CVS_Root
    cs.bc.edu:/usr/users1/church/cvsroot => $Church_CVS_Root
    types.bu.edu:/fs/church-data/cvsroot => $Church_CVS_Root
    types.bu.edu:/cs/church-data/cvsroot => $Church_CVS_Root
    types.bu.edu:/cvsroot => $Church_CVS_Root
    csb.bu.edu:/home/fac2/kfoury/Notes-for-several-papers => $JBW_BU_CVS_Root
    /home/fac2/kfoury/Notes-for-several-papers => $JBW_BU_CVS_Root
    types.bu.edu:/home/church/jbw/cvsroot => $JBW_BU_CVS_Root
    /u1/staff/polonovs/staff/SharedWork => $JBW_CVS_Area/polonovs-SharedWork
    selene.macs.hw.ac.uk:/u1/staff/polonovs/staff/SharedWork => $JBW_CVS_Area/polonovs-SharedWork
    selene.macs.hw.ac.uk:/u1/pg/sebc/cvs => $JBW_CVS_Host:/u1/pg/sebc/cvs
    selene.macs.hw.ac.uk:/u1/pg/mm20/CVS => $JBW_CVS_Host:/u1/pg/mm20/CVS
    selene.macs.hw.ac.uk:/u1/pg/mm20/tmpCVS => $JBW_CVS_Host:/u1/pg/mm20/tmpCVS

    :pserver:anoncvs\@subversions.gnu.org:/cvsroot/emacs => :pserver:anonymous\@cvs.savannah.gnu.org:/sources/emacs
    anoncvs\@subversions.gnu.org:/cvsroot/emacs => :pserver:anonymous\@cvs.savannah.gnu.org:/sources/emacs

    :pserver:anoncvs\@subversions.gnu.org:/cvsroot/w3 => :pserver:anonymous\@cvs.savannah.gnu.org:/sources/w3
    anoncvs\@subversions.gnu.org:/cvsroot/w3 => :pserver:anonymous\@cvs.savannah.gnu.org:/sources/w3

    :pserver:anoncvs\@subversions.gnu.org:/cvsroot/url => :pserver:anonymous\@cvs.savannah.gnu.org:/sources/url
    anoncvs\@subversions.gnu.org:/cvsroot/url => :pserver:anonymous\@cvs.savannah.gnu.org:/sources/url

    jbw\@subversions.gnu.org:/cvsroot/emaxml2 => jbw\@cvs.savannah.gnu.org:/sources/emaxml2
    jbw\@subversions.gnu.org:/webcvs/emaxml2 => jbw\@cvs.savannah.gnu.org:/web/emaxml2

    formdoc\@cluster.ags.uni-sb.de:/CVS/formdoc => formdoc\@lambda.ags.uni-sb.de:/share/CVS/ags/formdoc

    :pserver:jbw\@jbwcvs.macs.hw.ac.uk:/jbw-cvs/gc => :pserver:jbw\@jove.macs.hw.ac.uk:/jbw-cvs/gc
    :pserver:jbw\@jbwcvs.macs.hw.ac.uk:/jbw-cvs/share => :pserver:jbw\@jove.macs.hw.ac.uk:/jbw-cvs/share

EOF

my @CVS_Repository_Moves;

sub parse_moves {
    my $lines = shift;
    my @lines = split (/\n/, $lines);
    my $line;
    foreach $line (@lines) {
        next if ($line =~ m/^\s*(#|$)/); # skip comments and blank lines
        if ($line !~ m/^\s*([^\s=]+)\s*=>\s*(\S+)\s*$/) {
            print STDERR "$PROGRAM_NAME: Bad CVS repository move: $line\n";
            exit 1; }
        my (%m);
        $m{old} = $1;
        $m{new} = $2;
        $m{old_dir} = $m{old};
        $m{new_dir} = $m{new};
        $m{old_dir} =~ s/.*://;
        $m{new_dir} =~ s/.*://;
        $m{old_patt} = quotemeta ($m{old});
        $m{old_dir_patt} = quotemeta ($m{old_dir});
        push (@CVS_Repository_Moves, \%m); }}

sub show_help {
    print STDERR "Usage: $PROGRAM_NAME [OPTION]... [DIRECTORY]...\n";
    my $short_prog_name = $PROGRAM_NAME;
    $short_prog_name =~ s(.*/)();
    print STDERR "Try `perldoc $short_prog_name' for more information.\n";
    print STDERR "If that fails, try `perldoc $PROGRAM_NAME'.\n";
    print STDERR "If the output from perldoc looks unreadable, try `perldoc -t $PROGRAM_NAME'.\n"; }

sub dump_moves {
    my $m;
    foreach $m (@CVS_Repository_Moves) {
        my $k;
        foreach $k (keys %$m) {
            print "$k => $m->{$k}\n"; }
        print "\n"; }}

sub show_moves {
    my $m;
    foreach $m (@CVS_Repository_Moves) {
        print "old: $m->{old}\n";
        print "new: $m->{new}\n";
        print "\n"; }}

# crude hack, not always correct
sub containing_dir {
    my ($file) = @_;
    if ($file =~ m|^(.+)/[^/]+/*$|) {
        return $1; }
    elsif ($file =~ m|^/[^/]+/*$|) {
        return '/'; }
    else {
        print "file: $file\n";
        die "unhandled case"; }}

# file_okay (FILE)
#
# Tests whether FILE is readable, writable, and is in a writable
# directory.  Returns true if so, otherwise prints a warning and
# returns false.
#
sub file_okay {
    my $file = shift;
    my $currentdir = shift;
    my $parent = containing_dir ($file);
    if (! -f $file) {
        print STDERR
            "$PROGRAM_NAME: not detectably a file: $currentdir/$file\n"; 
        return 0; }
    if (! -r $file) {
        print STDERR
            "$PROGRAM_NAME: unreadable: $currentdir/$file\n";
        return 0; }
    if (! -w $file) {
        print STDERR
            "$PROGRAM_NAME: unwritable: $currentdir/$file\n";
        return 0; }
    if (! -w $parent) {
        print STDERR
            "$PROGRAM_NAME: unwritable directory: $currentdir/$parent\n";
        return 0; } 
    return 1; }

my $No_Action; # ***TODO*** implement this!
my $One_Change = 0;

sub find_cvs_mapping_for_root {
    my $root = shift;
    my $m;
    #print STDERR "root: [$root]\n";
    foreach $m (@CVS_Repository_Moves) {
        #print STDERR "m: [$m]\n";
        #print STDERR "m{old_patt}: [$$m{old_patt}]\n";
        if ($root =~ s,(^|\@)$$m{old_patt}/?(\n?)$,$1$$m{new}$2,) {
            return ($m, $root); }}
    return (undef, $root); }

sub find_cvs_files_and_fix_cvs_pointers {
    File::Find::find
        (sub {
            my $changed_file = 0;
            if (($_ eq 'CVS') && (-d 'CVS')) {
                if (!(file_okay ("CVS/Root", $File::Find::dir)
                      && file_okay("CVS/Repository",$File::Find::dir))){
                    print STDERR "$PROGRAM_NAME: "
                        . "skipping directory: $File::Find::dir\n";
                    return; }
                # print "dir: $File::Find::dir\n";
                my ($root, $repos);
                bind_to_files { "CVS/Root" => \$root, "CVS/Repository" => \$repos }, sub {
                    if ($root !~ m/^[^\n]+\n$/) {
                        die "contents of CVS/Root not a single line"; }
                    my ($m, $new_root) = find_cvs_mapping_for_root ($root);
                    return if ! defined $m;
                    print "directory: $File::Find::dir\n";
                    print "old root: $$m{old}\n";
                    if ($root ne "$$m{old}\n") {
                        print "old root with login: $root"; }
                    print "new root: $$m{new}\n";
                    if ($new_root ne "$$m{new}\n") {
                        print "new root with login: $new_root"; }
                    print "\n";
                    if (! $No_Action) {
                        $root = $new_root; }
                    #print STDERR "m{old_dir_patt}: $$m{old_dir_patt}\n";
                    #print STDERR "m{new_dir}: $$m{new_dir}\n";
                    # *** TODO: If $No_Action is set, still tell them
                    # what changes would have been made to the
                    # Repository file.
                    if ($repos =~ m(^/) && ! $No_Action) {
                        # old version of CVS with redundant
                        # information in CVS/Repository
                        if($repos !~ s!^$$m{old_dir_patt}/!$$m{new_dir}/!) {
                            print STDERR "repos: [$repos]\n";
                            print STDERR ("old_patt: "
                                          . "[$$m{old_patt}]\n");
                            print STDERR ("old_dir_patt: "
                                          ."[$$m{old_dir_patt}]\n");
                            die ("Root matches old_patt but "
                                 . "Repository doesn't match "
                                 . "old_dir_patt");
                        }}
                    else {
                        # new version of CVS has no
                        # redundant information in
                        # CVS/Repository!  Yay!  We dont
                        # have to do anything
                    }
                    #print "repos: [$repos]\n";
                    # for debugging, stop after one change
                    $changed_file = 1;
                }}
            if ($_ eq '.cvspass') {
                with_file_contents '.cvspass', sub {
                    my @lines = split (/\n/,$_,-1);
                    my $i;
                    my $changed = 0;
                    for ($i = 0; $i < $#lines; $i++) {
                        if ($lines[$i] =~ m/^(.*:pserver:)([^ ]+)( .*)$/) {
                            my ($prefix, $root, $suffix) = ($1, $2, $3);
                            my ($m, $new_root) = find_cvs_mapping_for_root ($root);
                            if ($root ne $new_root) {
                                $lines[$i] = $prefix . $new_root . $suffix;
                                if (! $changed) {
                                    $changed = 1;
                                    print "begin updating .cvspass file: $File::Find::dir/.cvspass\n\n"; }
                                print "old root: $root\n";
                                print "new root: $new_root\n\n"; }}}
                    if ($changed) {
                        print "end updating .cvspass file: $File::Find::dir/.cvspass\n\n";
                        # for debugging, stop after one file change
                        $changed_file = 1;
                    }
                    ($lines[$#lines] eq '') || die "bad .cvspass file";
                    if (! $No_Action) {
                        $_ = join ("\n", @lines); }}}
            if ($changed_file && $One_Change) {
                print "exiting after changing only one file\n\n";
                exit (0); }
        },
         @_); }

parse_moves ($Built_In_CVS_Repository_Moves);

my ($Show_Help, $Show_Moves);

if (! GetOptions ("help" => \$Show_Help,
                  "show-moves" => \$Show_Moves,
                  "no-action" => \$No_Action,
                  "one-change" => \$One_Change
                  )) {
    show_help();
    exit 1; }

if (! ($Show_Moves || $Show_Help || scalar (@ARGV))) {
    show_help();
    exit 1; }

show_moves() if $Show_Moves;
show_help() if $Show_Help;

if (scalar (@ARGV)) {
    find_cvs_files_and_fix_cvs_pointers (@ARGV); # "$ENV{'HOME'}"
}

=head1 NAME

fix-cvs-pointers - update CVS repository pointers in working directories

=head1 SYNOPSIS

B<fix-cvs-pointers> [I<OPTION>]... [I<DIRECTORY>]...

=head1 DESCRIPTION

This program contains a built-in set of CVS repository moves.  Each
move handles the movement of a CVS repository to a new location.  To
add a new move, B<fix-cvs-pointers> must be edited.

For each I<DIRECTORY>, B<fix-cvs-pointers> finds all CVS working
directories which are either I<DIRECTORY> or a descendant of
I<DIRECTORY>.  For each such working directory, B<fix-cvs-pointers>
checks the CVS/Root and CVS/Repository files to see if they point to a
repository that has moved.  If so, then B<fix-cvs-pointers> alters the
contents of CVS/Root and CVS/Repository to point to the new repository
location.

The options are:

=over 4

=item B<--show-moves>

List the built-in set of CVS repository moves.

=item B<--one-change>

Exit after changing only one file.  This is for when you are not quite
sure a new move is correct and you want to test it without changing a
zillion files.

=item B<--no-action>

Don't actually change any files.  The messages printed will indicate
files were changed, but nothing will actually happen.

=item B<--help>

Show this documentation.

=head1 DEPENDENCIES

B<fix-cvs-pointers> uses the B<JBW::Utils> module.

=head1 AUTHOR

Joe Wells (F<http://www.cee.hw.ac.uk/~jbw>)

=cut

# Local variables:
# mode: perl
# end: