#!/usr/bin/perl -w

use strict;
use Cwd;

## Modify these defaults for your platform.  For DOS, use @SUFFIXES = ("");
my $DIRSEP = "/";
my @SUFFIXES = (",v");

=head1 NAME

mrcs - use RCS programs on relocated RCS directories

=head1 SYNOPSIS

B<mci> [I<options>] I<file> ...

B<mco> [I<options>] I<file> ...

B<mrcs> I<options> I<file> ...

B<mrcsclean> [I<options>] [ I<file> ... ]

B<mrcsdiff> [B<-k>I<subst>] [B<-q>] [B<-r>I<rev1> [B<-r>I<rev2>]] [B<-T>] [B<-V>[I<n>]] [B<-x>I<suffixes>] [B<-z>I<zone>] [I<diff options>] I<file> ...

B<mrcsmerge> [I<options>] I<file> ...

B<mrlog> [I<options>] I<file> ...

=head1 DESCRIPTION

B<mrcs> automatically determines RCS file names from working file names.
Each file name is paired with its corresponding working file.  The
B<-xsuffixes> option as well as the B<RCSINIT> environment variable are
fully supported.  All option arguments are passed to the corresponding RCS
program verbatim and in the same order given.

RCS files are located by moving up in the directory tree until a directory
named RCS is found.  The removed path elements are then re-appended and a
search is done for the RCS file by suffix.

=head1 EXAMPLE

$ cd /devel/projectA/src/module1
$ mrlog file.c
rlog /devel/projectA/RCS/src/module1/file.c,v file.c

=head1 ENVIRONMENT

=over

=item B<RCSINIT>

This variable is searched for the B<-xsuffixes> option; it is ignored
otherwise.

=back

=cut

my @cwd = split(/${DIRSEP}/o, cwd);

## TODO: use File::Spec;

sub
splitpath($)
{
	my $file = shift;
	my @path;

	## split into path elements
	@path = split(/${DIRSEP}/, $file);

	## prepend current directory if file is relative
	unshift @path, @cwd  if ($path[0] ne "");
#	print STDERR "DEBUG: after abs\n", debugArray("path", @path);

	## remove "." and "" path elements
	@path = (shift @path, grep { !m/^[.]?$/ } @path);
#	print STDERR "DEBUG: after.\n", debugArray("path", @path);

	## remove ".." path elements
	if (grep(m/^[.][.]$/, @path)) {
#		warn "warning: stripping .. paths from $file\n";
		foreach ((@_, @path) = @path) {
			if (m/^[.][.]$/) {
				## don't remove the "root" directory
				pop @path  if @path > 1;
				next;
			}
			push @path, $_;
		}
#		print STDERR "DEBUG: after..\n", debugArray("path", @path);
	}

	return @path;
}


sub
pair($$)
{
	my($file,$create) = @_;
	my (@abspart, @relpart, $rcshead);

#	print STDERR "DEBUG: pair($file,$create)\n";

	## split file into canonical pathname list
	(@abspart, @relpart) = splitpath($_);

#	print STDERR "DEBUG:\n" debugArray("abs", @abspart);

	die "error: $file is in an RCS subdirectory\n"
		if (grep(m/^RCS$/, @abspart));

	## find parent RCS directory
	do {
		unshift @relpart, pop @abspart;
		$rcshead = join($DIRSEP, @abspart, "RCS");
#		print STDERR "DEBUG: Trying $rcshead\n";
	} until (0 == @abspart || -d $rcshead);

	if (0 == @abspart) {
		warn "failed to find RCS directory for $file\n";
		return undef;
	}

	## create sub directories under RCS
	if ($create) {
		my $dir = join($DIRSEP, $rcshead, @relpart[0..$#relpart-1]);
		unless (-d $dir) {
			my @command = ('mkdir', '-p', $dir);
			print STDERR join(' ', @command), "\n";
			system @command unless defined($ENV{MRCS_DEBUG});
		}
	}

	## found RCS directory
	$rcshead = join($DIRSEP, $rcshead, @relpart);

	## check for existing RCS file
	foreach my $suf (@SUFFIXES) {
		if (-f $rcshead . $suf) {
			## use existing RCS file
			return $rcshead . $suf;
		}
	}

	## RCS file does not exist; use default suffix
	return $rcshead . $SUFFIXES[0];
}

sub
checkForSuffixes($)
{
	@SUFFIXES = length $1 ? split(qr{/}, $1, -1) : ''
		if (shift =~ m/^-x(.*)/);
}

sub
main
{
	my (@command, $count, $rcsfile);

	## get RCS program name
	die "Invalid usage"
		unless $0 =~ s/^(?:|.+${DIRSEP})m([^${DIRSEP}]+)$/$1/;

	@command = $0;

	warn "warning: current directory is an RCS subdirectory\n"
		if grep(/^RCS$/, @cwd);

	## parse RCSINIT environment variable for -xsuffixes option
	checkForSuffixes($_)  foreach (split(' ', $ENV{RCSINIT} || ""));

	$count = 0;
	## parse command line
	foreach (@ARGV) {
		do { checkForSuffixes($_); next; } if (m/^-/);
		$count++;
		## got working file; find and insert RCS file into command line
		push @command, $rcsfile  if defined($rcsfile = pair($_, $0 eq "ci"));
	}
	continue {
		## forward all arguments to RCS program
		push @command, $_;
	}

	## check for built in commands and special cases
	for ($0) {
		## turn debug mode on
		m/^rcsdebug$/ && do {
			$ENV{MRCS_DEBUG} = 1;
			last;
		};

		## special case: rcsclean with no files specified
		m/^rcsclean$/ && $count == 0 && do {
			## find all working files in current directory
			opendir W, cwd;
			push @command,
				map {
					$rcsfile = pair($_, 0);
					defined($rcsfile) && -f $rcsfile && ++$count
						? ($rcsfile, $_)
						: ();
				}
				map {
					## rcsclean chokes on this case
					m/^-/ ? ".${DIRSEP}$_" : $_;
				}
				grep { -f $_ }
				readdir(W);
			closedir W;
			last;
		};
	}

	## execute RCS program
	print STDERR join(' ', @command), "\n";
	exec @command unless defined($ENV{MRCS_DEBUG});
}

sub
debugArray
{
	my $name = shift;
	my $out = sprintf("\@%s = %d\n", $name, scalar @_);
	for (my $i = 0; $i < @_; $i++) {
		$out .= sprintf("\$%s[%d] eq \"%s\"\n", $name, $i, $_[$i]);
	}
	return $out;
}

main();