mdw@git.distorted.org.uk Git - sgt/utils/blob - lns/lns

   1 #!/usr/bin/env perl
   2
   3 # lns -- create a symbolic link. Alternative to "ln -s".
   4 # This program works more like "cp", in that the source path name is not
   5 # taken literally.
   6 #    ln -s filename /tmp
   7 # creates a link
   8 #    /tmp/filename -> filename
   9 # whereas we would prefer
  10 #    /tmp/filename -> /home/me/filename
  11 # or wherever the file *really* was.
  12 #
  13 # Usage: lns [-afF] file1 file2
  14 #     or lns [-af] file1 [file2...] dir
  15 #
  16 # Where:
  17 #   -a means absolute - "symlink /usr/bin/argh /usr/local/bin/argh" produces
  18 #      a relative link "/usr/bin/argh -> ../local/bin/argh", but using the
  19 #      -a option will give a real absolute link.
  20 #   -f means forceful - overwrite the target filename if it exists *and* is
  21 #      a link. You can't accidentally overwrite real files like this.
  22 #   -q means quiet - don't complain if we fail to do the job.
  23 #   -v means verbose - say what we're doing.
  24 #   -F means FILE - forces interpretation to be the "file1 file2" syntax,
  25 #      even if file2 is a link to a directory. This option implies -f.
  26
  27 use Cwd;
  28
  29 $usage =
  30   "usage: lns [flags] srcfile destfile\n".
  31   "   or: lns [flags] srcfile [srcfile...] destdir\n".
  32   "where: -a               create symlinks with absolute path names\n".
  33   "       -f               overwrite existing symlink at target location\n".
  34   "       -F               like -f, but works even if target is link to dir\n".
  35   "       -v               verbosely log activity (repeat for more verbosity)\n".
  36   "       -q               suppress error messages on failure\n".
  37   " also: lns --version    report version number\n" .
  38   "       lns --help       display this help text\n" .
  39   "       lns --licence    display (MIT) licence text\n";
  40
  41 $licence =
  42   "lns is copyright 1999,2004 Simon Tatham.\n" .
  43   "\n" .
  44   "Permission is hereby granted, free of charge, to any person\n" .
  45   "obtaining a copy of this software and associated documentation files\n" .
  46   "(the \"Software\"), to deal in the Software without restriction,\n" .
  47   "including without limitation the rights to use, copy, modify, merge,\n" .
  48   "publish, distribute, sublicense, and/or sell copies of the Software,\n" .
  49   "and to permit persons to whom the Software is furnished to do so,\n" .
  50   "subject to the following conditions:\n" .
  51   "\n" .
  52   "The above copyright notice and this permission notice shall be\n" .
  53   "included in all copies or substantial portions of the Software.\n" .
  54   "\n" .
  55   "THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,\n" .
  56   "EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF\n" .
  57   "MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND\n" .
  58   "NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS\n" .
  59   "BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN\n" .
  60   "ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN\n" .
  61   "CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE\n" .
  62   "SOFTWARE.\n";
  63
  64 $abs=$force=$quiet=$verbose=$FILE=0;
  65 while ($_=shift @ARGV) {
  66   last if /^--$/;
  67   unshift (@ARGV, $_), last unless /^-(.*)/;
  68   if ($1 eq "-help") {
  69     print STDERR $usage;
  70     exit 0;
  71   } elsif ($1 eq "-version") {
  72     if ('$Revision$' =~ /Revision:\s+(\d+)/) {
  73         print "lns revision $1\n";
  74     } else {
  75         print "lns: unknown revision\n";
  76     }
  77     exit 0;
  78   } elsif ($1 eq "-licence" or $1 eq "-license") {
  79     print $licence;
  80     exit 0;
  81   } else {
  82     foreach $opt (split //, $1) {
  83         if ($opt eq "a") { $abs=1; }
  84         elsif ($opt eq "f") { $force=1; }
  85         elsif ($opt eq "q") { $quiet=1; }
  86         elsif ($opt eq "v") { $verbose++; }
  87         elsif ($opt eq "F") { $force=$FILE=1; }
  88         else { die "lns: unrecognised option '-$1'\n"; }
  89     }
  90   }
  91 }
  92
  93 die $usage if $#ARGV < 1;
  94
  95 die "lns: multiple source files specified with -F option\n"
  96   if $#ARGV > 1 && $FILE;
  97 die "lns: -q (quiet) and -v (verbose) options both specified\n"
  98   if $quiet && $verbose;
  99
 100 $target = pop @ARGV;
 101 die "lns: multiple source files specified, $target not a directory\n"
 102   if $#ARGV > 0 && !-d $target;
 103
 104 $multiple = (-d $target && !$FILE);
 105
 106 $target =~ s/// if $target =~ /\/$/;    # strip trailing slash if present
 107
 108 if ($multiple) {
 109   foreach $source (@ARGV) {
 110     $source =~ /^(.*\/)?([^\/]*)$/;     # find final file name component
 111     &makelink($source, "$target/$2");   # actually make a link
 112   }
 113 } else {
 114   $source = $ARGV[0];                   # only one source file
 115   &makelink($source, $target);          # make the link
 116 }
 117
 118 sub makelink {
 119   local ($source, $target) = @_;
 120
 121   # If the target exists...
 122   if (-e $target || readlink $target) {
 123     # If it's a symlink and we're in Force mode, remove it and carry on.
 124     if ($force && readlink $target) {
 125       unlink $target || die "lns: unable to remove link $target\n";
 126       # Report that if in Verbose mode.
 127       warn "lns: removing existing target link $target\n" if $verbose;
 128     } else {
 129       # Otherwise, fail. Report that fact if not in Quiet mode.
 130       warn "lns: failed to link $source to $target: target exists\n"
 131         if !$quiet;
 132       return;
 133     }
 134   }
 135
 136   # OK, now we're ready to do the link. Calculate the absolute path names
 137   # of both source and target.
 138   $source = &normalise($source);
 139   $target = &normalise($target);
 140
 141   # If we're in Relative mode (the default), calculate the relative path
 142   # name we will reference the source by.
 143   $sourcename = $abs ? $source : &relname($source, $target);
 144
 145   warn "lns: linking $source: $target -> $sourcename\n" if $verbose;
 146
 147   # Make the link
 148   symlink($sourcename, $target) || die "lns: unable to make link to $target\n";
 149 }
 150
 151 sub normalise {
 152     # Normalise a path into an absolute one containing no . or ..
 153     # segments.
 154     local ($_) = @_;
 155
 156     # Make relative paths absolute.
 157     $_ = getcwd() . "/" . $_ if !/^\//;
 158
 159     # Remove "." segments.
 160     1 while s/^(.*)\/\.(\/.*)?$/$1$2/;
 161
 162     # Remove redundant slashes.
 163     s/\/+/\//;
 164
 165     # Remove a trailing slash if present.
 166     s/\/$//;
 167
 168     # Remove ".." segments. This is the hard bit, because a
 169     # directory segment that's a _symlink_ doesn't do the obvious
 170     # thing if followed by "..". But we can't just call realpath,
 171     # because we do want to preserve symlinks where they _don't_
 172     # interfere with this sort of work. So the algorithm is:
 173     #
 174     #  - Repeatedly search for the rightmost `directory/..'
 175     #    fragment.
 176     #  - When we find it, one of two cases apply.
 177     #     * If the directory before the .. is not a symlink, we can
 178     #       remove both it and the .. from the string.
 179     #     * If it _is_ a symlink, we substitute it for its link
 180     #       text, and loop round again.
 181     while (/^(.*)\/((\.|\.\.[^\/]+|\.?[^\/\.][^\/]*)\/\.\.)(\/.*)?$/)
 182     {
 183         my ($pre, $dir, $frag, $post) = ($1,$2,$3,$4);
 184         my $log = "transforming $target -> ";
 185         if (-l "$pre/$frag") {
 186             my $linktext = readlink "$pre/$frag";
 187             if ($linktext =~ /^\//) { # absolute link
 188                 $_ = $linktext;
 189             } else { # relative link
 190                 $_ = "$pre/$linktext";
 191             }
 192             $_ .= "/.." . $post;
 193         } else {
 194             $_ = $pre . $post;
 195         }
 196         $_ = "/" if $_ eq ""; # special case
 197         $log .= "$target";
 198         warn "lns: $log\n" if $verbose > 1;
 199     }
 200
 201     # The only place where a ".." fragment might still remain is at
 202     # the very start of the string, and "/.." is defined to be
 203     # equivalent to "/".
 204     1 while s/^\/\.\.\//\//;
 205
 206     return $_;
 207 }
 208
 209 sub relname {
 210   local ($source, $target) = @_;
 211   local $prefix;
 212
 213   # Strip the last word off the target (the actual file name) to
 214   # obtain the target _directory_.
 215   $target =~ s/\/[^\/]*$//;
 216
 217   # Our starting prefix is empty. We will add one "../" at a time
 218   # until we find a match.
 219
 220   while (1) {
 221
 222     # If $target is _precisely_ $source, we are done.
 223     if ($target eq $source) {
 224       return "." if $prefix eq "";
 225       $prefix =~ s/\/$//;
 226       return $prefix;
 227     }
 228
 229     # If $target is a prefix of $source, we are done. (No matter what
 230     # symlinks may exist on the shared common pathname, if we are
 231     # linking `a/b/c/foo' to `foo' then a simple relative link will
 232     # work.)
 233     if (substr($source, 0, 1 + length $target) eq "$target/") {
 234        return $prefix . substr($source, 1 + length $target); # skip the slash
 235     }
 236
 237     # Otherwise, descend to "..".
 238     $target = &normalise($target . "/..");
 239
 240     # Now we have replaced $target with a pathname equivalent to
 241     # `$target/..'. So add a "../" to $prefix, and try matching
 242     # again.
 243     $prefix .= "../";
 244   }
 245 }