My user-friendly symlinking tool `lns' is another thing that really

[sgt/utils] / lns / lns

#!/usr/bin/env perl

# lns -- create a symbolic link. Alternative to "ln -s".
# This program works more like "cp", in that the source path name is not
# taken literally.
#    ln -s filename /tmp
# creates a link
#    /tmp/filename -> filename
# whereas we would prefer
#    /tmp/filename -> /home/me/filename
# or wherever the file *really* was.
#
# Usage: lns [-afF] file1 file2
#     or lns [-af] file1 [file2...] dir
#
# Where:
#   -a means absolute - "symlink /usr/bin/argh /usr/local/bin/argh" produces
#      a relative link "/usr/bin/argh -> ../local/bin/argh", but using the
#      -a option will give a real absolute link.
#   -f means forceful - overwrite the target filename if it exists *and* is
#      a link. You can't accidentally overwrite real files like this.
#   -q means quiet - don't complain if we fail to do the job.
#   -v means verbose - say what we're doing.
#   -F means FILE - forces interpretation to be the "file1 file2" syntax,
#      even if file2 is a link to a directory. This option implies -f.

use Cwd;

$usage =
  "usage: lns [flags] srcfile destfile\n".
  "   or: lns [flags] srcfile [srcfile...] destdir\n".
  "where: -a               create symlinks with absolute path names\n".
  "       -f               overwrite existing symlink at target location\n".
  "       -F               like -f, but works even if target is link to dir\n".
  "       -v               verbosely log activity (repeat for more verbosity)\n".
  "       -q               suppress error messages on failure\n".
  " also: lns --version    report version number\n" .
  "       lns --help       display this help text\n" .
  "       lns --licence    display (MIT) licence text\n";

$licence =
  "lns is copyright 1999,2004 Simon Tatham.\n" .
  "\n" .
  "Permission is hereby granted, free of charge, to any person\n" .
  "obtaining a copy of this software and associated documentation files\n" .
  "(the \"Software\"), to deal in the Software without restriction,\n" .
  "including without limitation the rights to use, copy, modify, merge,\n" .
  "publish, distribute, sublicense, and/or sell copies of the Software,\n" .
  "and to permit persons to whom the Software is furnished to do so,\n" .
  "subject to the following conditions:\n" .
  "\n" .
  "The above copyright notice and this permission notice shall be\n" .
  "included in all copies or substantial portions of the Software.\n" .
  "\n" .
  "THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,\n" .
  "EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF\n" .
  "MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND\n" .
  "NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS\n" .
  "BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN\n" .
  "ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN\n" .
  "CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE\n" .
  "SOFTWARE.\n";

$abs=$force=$quiet=$verbose=$FILE=0;
while ($_=shift @ARGV) {
  last if /^--$/;
  unshift (@ARGV, $_), last unless /^-(.*)/;
  if ($1 eq "-help") {
    print STDERR $usage;
    exit 0;
  } elsif ($1 eq "-version") {
    if ('$Revision$' =~ /Revision:\s+(\d+)/) {
	print "lns revision $1\n";
    } else {
	print "lns: unknown revision\n";
    }
    exit 0;
  } elsif ($1 eq "-licence" or $1 eq "-license") {
    print $licence;
    exit 0;
  } else {
    foreach $opt (split //, $1) {
	if ($opt eq "a") { $abs=1; }
	elsif ($opt eq "f") { $force=1; }
	elsif ($opt eq "q") { $quiet=1; }
	elsif ($opt eq "v") { $verbose++; }
	elsif ($opt eq "F") { $force=$FILE=1; }
	else { die "$0: unrecognised option '-$1'\n"; }
    }
  }
}

die $usage if $#ARGV < 1;

die "$0: multiple source files specified with -F option\n"
  if $#ARGV > 1 && $FILE;
die "$0: -q (quiet) and -v (verbose) options both specified\n"
  if $quiet && $verbose;

$target = pop @ARGV;
die "$0: multiple source files specified, $target not a directory\n"
  if $#ARGV > 0 && !-d $target;

$multiple = (-d $target && !$FILE);
$whereami = getcwd();

$target =~ s/// if $target =~ /\/$/;    # strip trailing slash if present

if ($multiple) {
  foreach $source (@ARGV) {
    $source =~ /^(.*\/)?([^\/]*)$/;     # find final file name component
    &makelink($source, "$target/$2");   # actually make a link
  }
} else {
  $source = $ARGV[0];                   # only one source file
  &makelink($source, $target);          # make the link
}

sub makelink {
  local ($source, $target) = @_;

  # If the target exists...
  if (-e $target || readlink $target) {
    # If it's a symlink and we're in Force mode, remove it and carry on.
    if ($force && readlink $target) {
      unlink $target || die "$0: unable to remove link $target\n";
      # Report that if in Verbose mode.
      warn "$0: removing existing target link $target\n" if $verbose;
    } else {
      # Otherwise, fail. Report that fact if not in Quiet mode.
      warn "$0: failed to link $source to $target: target exists\n"
        if !$quiet;
      return;
    }
  }

  # OK, now we're ready to do the link. Calculate the absolute path names
  # of both source and target.
  $source = &absolute($source);
  $target = &absolute($target);

  # If we're in Relative mode (the default), calculate the relative path
  # name we will reference the source by.
  $sourcename = $abs ? $source : &relname($source, $target);

  warn "$0: linking $source: $target -> $sourcename\n" if $verbose;

  # Make the link
  symlink($sourcename, $target) || die "$0: unable to make link to $target\n";
}

sub absolute {
  local ($_) = @_;
  $_ = "$whereami/$_" if !/^\//;
  s//$whereami/ if /^\./;
  1 while s/\/\.\//\//;
  1 while s/\/\//\//;
  1 while s/\/[^\/]+\/\.\.//;
  1 while s/^\/\.\.\//\//;
  $_;
}

sub relname {
  local ($source, $target) = @_;
  local $prefix;

  # Strip the last word off the target (the actual file name) to
  # obtain the target _directory_.
  $target =~ s/\/[^\/]*$//;

  # Our starting prefix is empty. We will add one "../" at a time
  # until we find a match.

  while (1) {

    # If $target is a prefix of $source, we are done. (No matter what
    # symlinks may exist on the shared common pathname, if we are
    # linking `a/b/c/foo' to `foo' then a simple relative link will
    # work.)
    if (substr($source, 0, length $target) eq $target) {
       return $prefix . substr($source, 1 + length $target); # skip the slash
    }

    # Otherwise, descend to "..".

    $target = $target . "/..";

    # Now normalise the path by removing all ".." segments. We want
    # to do this while _as far as possible_ preserving symlinks. So
    # the algorithm is:
    #
    #  - Repeatedly search for the rightmost `directory/..'
    # 	 fragment.
    #  - When we find it, one of two cases apply.
    # 	  * If the directory before the .. is not a symlink, we can
    # 	    remove both it and the .. from the string.
    # 	  * If it _is_ a symlink, we substitute it for its link
    # 	    text, and loop round again.
    while ($target =~
	   /^(.*)\/((\.|\.\.[^\/]+|\.?[^\/\.][^\/]*)\/\.\.)(\/.*)?$/)
    {
	my ($pre, $dir, $frag, $post) = ($1,$2,$3,$4);
	my $log = "transforming $target -> ";
	if (-l "$pre/$frag") {
	    my $linktext = readlink "$pre/$frag";
	    if ($linktext =~ /^\//) { # absolute link
		$target = $linktext;
	    } else { # relative link
		$target = "$pre/$linktext";
	    }
	    $target .= "/.." . $post;
	} else {
	    $target = $pre . $post;
	}
	$target = "/" if $target eq ""; # special case
	$log .= "$target";
	warn "$0: $log\n" if $verbose > 1;
    }

    # Now we have replaced $target with a pathname equivalent to
    # `$target/..'. So add a "../" to $prefix, and try matching
    # again.
    $prefix .= "../";
  }
}