--- /dev/null
+#!/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 .= "../";
+ }
+}
~mdw / sgt / utils / blobdiff