#!/usr/sww/bin/perl
#
# lnsrctree - create shadow link tree

print STDERR "lnsrctree -- Perl version\n";

# the name of the file to which all symbolic links in a directory are anchored
#
$ANCHORLINK = '.-].';

# save the program name
#
$PROGNAME = $0;

# set to 1 to enable debugging
#
$DEBUG = 0;

# make sure we can do symlinks
#
(eval 'symlink("", "");', $@ eq '') ||
  die "Either OS or Perl doesn't support symbolic links!\n";

# process argument list
#
&getArgs();

# make sure STDOUT is unbuffered if we're debugging
#
if ($DEBUG) {
  select(STDOUT);
  $| = 1;
  select(STDERR);
}

# make sure source directory exists
#
$sourcedir = shift(@ARGV);
@sstat = lstat($sourcedir);
if (! -d _) {
  print STDERR "$PROGNAME: '$sourcedir' is not a directory!\n";
  die $USAGE;
}
chop($sourcedir = `(cd $sourcedir; pwd)`);
die "Couldn't find source directory!\n" if (!$sourcedir);

# save target directory (if they specified one)
#
if (@ARGV == 1) {
  $targetdir = shift(@ARGV);

  # create directories if they don't exist
  #
  @tstat = lstat($targetdir);
  if (-e _) {
    if ($sstat[0] == $tstat[0] && $sstat[1] == $tstat[1]) {
      print STDERR "$PROGNAME: Source and target directory are the same!\n";
      exit(1);
    }
    exit(1) if (&ask_yes_or_no("Overwrite $targetdir? ") != 'y');
    &destroy($targetdir);
  }
  die "$PROGNAME: $! for 'mkdir $badpath'\n"
    if (defined($badpath = &mkdirhier($targetdir)));
} else {
  $targetdir = '.';
}
chop($targetdir = `(cd $targetdir; pwd)`);
die "Couldn't find target directory!\n" if (!$targetdir);

&lnsrctree($sourcedir, $sourcedir, $targetdir);

exit 0;

#########################################################################
#
#	Ask $question, return an answer from @response
#
sub ask_question {
  local($question, $case_sensitive, @response) = @_;
  local($_, $r);

  while (1) {

    # ask a question, get an answer
    #
    print STDOUT $question;
    chop($_ = <STDIN>);

    # clean up the answer
    #
    s/^\s+//;
    s/\s$//;
    tr/A-Z/a-z/ if (!$case_sensitive);

    # find answer in list of valid responses
    #
    foreach $r (@response) {
      return $r if ($r eq $_);
    }

    # print list of valid responses
    #
    print STDERR 'Please answer ';
    for ($r = 0; $r < @response; $r++) {
      print STDERR ($r == $#response ? ' or ' : ', ') if ($r > 0);
      print STDERR "'$response[$r]'";
    }
    print STDERR "\n";
  }
}

#########################################################################
#
#	Ask $question, return 'y' or 'n'
#
sub ask_yes_or_no {
  local($question) = @_;

  return substr(&ask_question($question, 0, 'y', 'n', 'yes', 'no'), 0, 1);
}

#########################################################################
#
#	Create all directories necessary to ensure that $fullpath exists
#
sub mkdirhier {
  local($fullpath) = @_;
  local($dir, @dirs);

  # break the path into its component parts
  #
  @dirs = split(/\//, $fullpath);
  $fullpath = '';

  # make sure each level has been created
  #
  while (defined($dir = shift(@dirs))) {
    if ($dir) {
      $fullpath .= $dir;
      if (! -d $fullpath) {
	print STDERR "M: Creating directory $fullpath\n" if ($DEBUG);
	return $fullpath if (!mkdir($fullpath, 0777));
      }
    }
    $fullpath .= '/' if ($fullpath !~ /\/$/);
  }

  # return nothing if it worked
  #
  return undef;
}

#########################################################################
#
#	Obliterate a file/directory
#
sub destroy {
  local($dir) = @_;
  local(*DIR);
  local($file);

  if ((! -d $dir) || (-l $dir)) {
    # handle nondirectories
    #
    unlink($dir);
  } else {
    # unlink directory (and everything it contains)
    #
    if (opendir(DIR, $dir)) {
      while ($file = readdir(DIR)) {
	&destroy("$dir/$file") if (($file ne '.') && ($file ne '..'));
      }
      closedir(DIR);
    }
    rmdir($dir);
  }
}

#########################################################################
#
#	Create a symlink at $targetdir/$ANCHORLINK
#	pointing to $sourcedir
#
sub anchorlink {
  local($sourcedir, $targetdir) = @_;
  local($anchorlink, $linktext);

  $anchorlink = "$targetdir/$ANCHORLINK";
  lstat($anchorlink);
  if (-e _) {

    # we're done if the anchor link already points to this file
    #
    $linktext = readlink($anchorlink);
    return if ($linktext eq $sourcedir);

    # get rid of old link
    #
    &destroy($anchorlink);
  }

  print STDERR "A: Creating $targetdir/$ANCHORLINK -> $sourcedir\n"
    if ($DEBUG);

  symlink($sourcedir, $anchorlink);
}

#########################################################################
#
#	 Create a link to $file via the anchor link
#
sub linklink {
  local($sourcedir, $targetdir, $file) = @_;
  local($path);
  local($linktext, $linkfile);

  # if the target symlink already exists in some form
  #
  $path = "$targetdir/$file";
  $linkfile = readlink("$sourcedir/$file");
  lstat($path);
  if ( -e _) {

    # get text of target symlink
    #
    $linktext = (-l _ ? readlink($path) : undef);

    # we're done if the target link is already correct
    #
    return if ($linktext eq $linkfile);

    # get rid of old link
    #
    &destroy($path);
  }

  if ($DEBUG) {
    print STDERR "L: Creating $path -> $linkfile";
    print STDERR " (formerly $file -> $linktext)" if ($linktext);
    print STDERR "\n";
  }

  symlink($linkfile, $path);
}

#########################################################################
#
#	 Create a link to $file via the anchor link
#
sub linkfile {
  local($targetdir, $file) = @_;
  local($path);
  local($linktext, $linkfile);

  # if the target symlink already exists in some form
  #
  $path = "$targetdir/$file";
  $linkfile = "$ANCHORLINK/$file";
  lstat($path);
  if ( -e _) {

    # get text of target symlink
    #
    $linktext = (-l _ ? readlink($path) : undef);

    # we're done if the target link is already correct
    #
    return if ($linktext eq $linkfile);

    # get rid of old link
    #
    &destroy($path);
  }

  if ($DEBUG) {
    print STDERR "F: Creating $path -> $linkfile";
    print STDERR " (formerly $file -> $linktext)" if ($linktext);
    print STDERR "\n";
  }

  symlink($linkfile, $path);
}

#########################################################################
#
#	Links to source revision directories should be symlinks
#
sub rcslink {
  local($targetdir, $file) = @_;
  local($path);
  local($linktext, $linkfile);

  # see if the anchor link already points to this file
  #
  $path = "$targetdir/$file";
  $linkfile = "$ANCHORLINK/$file";
  lstat($path);
  if (-e _) {

    # get text of target symlink
    #
    $linktext = (-l _ ? readlink($path) : undef);

    # we're done if the target link is already correct
    #
    return if ($linktext eq $linkfile);

    # get rid of old link
    #
    &destroy($path);
  }

  print STDERR "R: Creating $path -> $linkfile\n" if ($DEBUG);

  symlink($linkfile, $path);
}

#########################################################################
#
#	 Create a subdirectory
#
sub linkdir {
  local($sourcedir, $targetdir, $anchordir, $file) = @_;

  if ($file eq 'RCS' || $file eq 'SCCS') {
    &rcslink($targetdir, $file);
  } else {

    # make sure $path is a directory
    #
    $path = "$targetdir/$file";
    lstat($path);
    if (! -e _ || ! -d _) {
      &destroy($path) if (! -d _);
      mkdir($path, 0777);
    }

    &lnsrctree("$sourcedir/$file", "$anchordir/$file", $path);
  }
}

#########################################################################
#
#	Link $targetdir to $sourcedir using $anchordir as the link
#
sub lnsrctree {
  local($sourcedir, $anchordir, $targetdir) = @_;
  local(*DIR);
  local($file, $sourcefile);

  # create the anchor for this directory
  #
  &anchorlink($anchordir, $targetdir);

  # fix anchor for subdirectories
  #
  if (substr($anchordir, 0, 1) eq '/') {
    $anchordir = '../.-].';
  } else {
    $anchordir = '../' . $anchordir;
  }

  # now create symlinks for all files in the directory
  #
  if (opendir(DIR, $sourcedir)) {
    while ($file = readdir(DIR)) {
      if ($file ne '.' && $file ne '..' && $file ne $ANCHORLINK) {
	if (-l "$sourcedir/$file") {
	  &linklink($sourcedir, $targetdir, $file);
	} elsif (-d _) {
	  &linkdir($sourcedir, $targetdir, $anchordir, $file);
	} else {
	  &linkfile($targetdir, $file);
	}
      }
    }
    closedir(DIR);
  }
}

# process arguments
#
sub getArgs {
  local($usage) = (0, 0);
  local(@nonargs);
  local($_);

  while ($_ = shift(@ARGV)) {
    if (s/^-//) {

      # check for valid option
      #
      if (/^D/) {
	$DEBUG = 1;
      }

      # bad arg
      #
      else {
	print STDERR "$PROGNAME: Invalid argument '$_'!\n";
	$usage = 1;
      }
    } else {

      push(@nonargs, $_);
    }
  }

  # make sure we got two directories
  #
  $usage = 1 if (@nonargs != 2);

  # if they screwed up, print usage message and die
  #
  if ($usage) {
    print STDERR "Usage: $PROGNAME";
    print STDERR " [-D(ebug)]";
    print STDERR " fromdir todir\n";
    exit 1;
  }

  @ARGV = @nonargs;
}