[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;
use POSIX; # for opendir and friends

$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".
  "       -r               recursively construct a directory tree which\n".
  "                        mirrors the source, with symlinks to all files\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=$recurse=$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 "r") { $recurse=1; }
	elsif ($opt eq "v") { $verbose++; }
	elsif ($opt eq "F") { $force=$FILE=1; }
	else { die "lns: unrecognised option '-$1'\n"; }
    }
  }
}

die $usage if $#ARGV < 1;

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

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

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

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

if ($multiple) {
  foreach $source (@ARGV) {
    # We must path-normalise $source _before_ looking for the final
    # filename component, to deal with the case of `lns . subdir'
    # in which we want the link to be called subdir/<dirname> rather
    # than subdir/. .
    $source = &normalise($source);
    $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) = @_;
  # Calculate the absolute path names of both source and target.
  $source = &normalise($source);
  $target = &normalise($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);

  my $donothing = 0;
  my $recursing = $recurse && -d $source;
  my $ok;
  # If the target exists...
  if (-e $target || readlink $target) {
    if ($recursing && -d $target) {
      # If it's a directory and we're in recursive mode, just do nothing
      # and work around it.
      $donothing = 1;
    } elsif ($force && readlink $target) {
      # If it's a symlink and we're in Force mode, remove it and carry on.
      unlink $target || die "lns: unable to remove link $target\n";
      # Report that if in Verbose mode.
      warn "lns: removing existing target link $target\n" if $verbose;
    } else {
      # Otherwise, fail. Report that fact if not in Quiet mode.
      warn "lns: failed to link $source to $target: target exists\n"
        if !$quiet;
      return;
    }
  }

  if ($recursing) {
    # Make the directory.
    if ($donothing) {
      warn "lns: directory $target already exists, no need to create it\n"
          if $verbose;
      $ok = 1;
    } else {
      warn "lns: making directory $target\n"
          if $verbose;
      if (mkdir $target) {
        $ok = 1;
      } else {
        warn "lns: unable to make directory '$target': $!\n";
      }
    }
    # Now recurse into it.
    if ($ok) {
      my $dh = POSIX::opendir($source);
      my @files = POSIX::readdir($dh);
      my $f;
      POSIX::closedir($dh);
      foreach $f (@files) {
        next if $f eq "." or $f eq "..";
        &makelink("$source/$f", "$target/$f");
      }
    }
  } else {
    # Make the link.
    warn "lns: linking $source: $target -> $sourcename\n" if $verbose;
    symlink($sourcename, $target) || die "lns: unable to make link to $target\n";
  }
}

sub normalise {
    # Normalise a path into an absolute one containing no . or ..
    # segments.
    local ($_) = @_;

    warn "lns: path normalisation required on $_\n" if $verbose > 2;

    # Make relative paths absolute.
    $_ = getcwd() . "/" . $_ if !/^\//;

    # Remove "." segments.
    1 while s/^(.*)\/\.(\/.*)?$/$1$2/;

    # Remove redundant slashes.
    s/\/+/\//g;

    # Remove a trailing slash if present.
    s/\/$//;

    # Remove ".." segments. This is the hard bit, because a
    # directory segment that's a _symlink_ doesn't do the obvious
    # thing if followed by "..". But we can't just call realpath,
    # because we do want to preserve symlinks where they _don't_
    # interfere with this sort of work. 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 (/^(.*)\/((\.|\.\.[^\/]+|\.?[^\/\.][^\/]*)\/\.\.)(\/.*)?$/)
    {
	my ($pre, $dir, $frag, $post) = ($1,$2,$3,$4);
	my $log = "  transforming $_ -> ";
	if (-l "$pre/$frag") {
	    my $linktext = readlink "$pre/$frag";
	    if ($linktext =~ /^\//) { # absolute link
		$_ = $linktext;
	    } else { # relative link
		$_ = "$pre/$linktext";
	    }
	    $_ .= "/.." . $post;
	} else {
	    $_ = $pre . $post;
	}
	$_ = "/" if $_ eq ""; # special case
	s/\/+/\//g; # remove redundant slashes again in case link text had any
	$log .= "$_";
	warn "lns: $log\n" if $verbose > 2;
    }

    # The only place where a ".." fragment might still remain is at
    # the very start of the string, and "/.." is defined to be
    # equivalent to "/".
    1 while s/^\/\.\.(\/(.*))?$/\/$2/;

    warn "lns: path normalisation returned $_\n" if $verbose > 2;

    return $_;
}

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) {

    warn "lns: trying prefix '$prefix': looking for $target as prefix of $source\n" if $verbose > 1;

    # If $target is _precisely_ $source, we are done.
    if ($target eq $source) {
      return "." if $prefix eq "";
      $prefix =~ s/\/$//;
      return $prefix;
    }

    # 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, 1 + length $target) eq "$target/") {
      warn "lns: found it\n" if $verbose > 1;
      return $prefix . substr($source, 1 + length $target); # skip the slash
    } elsif ($target eq "/") {
      warn "lns: found it\n" if $verbose > 1;
      return $prefix . substr($source, 1); # special case
    }

    # Otherwise, descend to "..".
    $target = &normalise($target . "/..");

    # Now we have replaced $target with a pathname equivalent to
    # `$target/..'. So add a "../" to $prefix, and try matching
    # again.
    $prefix .= "../";
  }
}
Commit	Line	Data
337ff285	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;
53ddbe1a	28	use POSIX; # for opendir and friends
337ff285	29
	30	$usage =
	31	"usage: lns [flags] srcfile destfile\n".
	32	" or: lns [flags] srcfile [srcfile...] destdir\n".
	33	"where: -a create symlinks with absolute path names\n".
	34	" -f overwrite existing symlink at target location\n".
	35	" -F like -f, but works even if target is link to dir\n".
53ddbe1a	36	" -r recursively construct a directory tree which\n".
53ddbe1a	37	" mirrors the source, with symlinks to all files\n".
337ff285	38	" -v verbosely log activity (repeat for more verbosity)\n".
	39	" -q suppress error messages on failure\n".
	40	" also: lns --version report version number\n" .
	41	" lns --help display this help text\n" .
	42	" lns --licence display (MIT) licence text\n";
	43
	44	$licence =
	45	"lns is copyright 1999,2004 Simon Tatham.\n" .
	46	"\n" .
	47	"Permission is hereby granted, free of charge, to any person\n" .
	48	"obtaining a copy of this software and associated documentation files\n" .
	49	"(the \"Software\"), to deal in the Software without restriction,\n" .
	50	"including without limitation the rights to use, copy, modify, merge,\n" .
	51	"publish, distribute, sublicense, and/or sell copies of the Software,\n" .
	52	"and to permit persons to whom the Software is furnished to do so,\n" .
	53	"subject to the following conditions:\n" .
	54	"\n" .
	55	"The above copyright notice and this permission notice shall be\n" .
	56	"included in all copies or substantial portions of the Software.\n" .
	57	"\n" .
	58	"THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,\n" .
	59	"EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF\n" .
	60	"MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND\n" .
	61	"NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS\n" .
	62	"BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN\n" .
	63	"ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN\n" .
	64	"CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE\n" .
	65	"SOFTWARE.\n";
	66
53ddbe1a	67	$abs=$force=$quiet=$verbose=$recurse=$FILE=0;
337ff285	68	while ($_=shift @ARGV) {
	69	last if /^--$/;
	70	unshift (@ARGV, $_), last unless /^-(.*)/;
	71	if ($1 eq "-help") {
	72	print STDERR $usage;
	73	exit 0;
	74	} elsif ($1 eq "-version") {
	75	if ('$Revision$' =~ /Revision:\s+(\d+)/) {
	76	print "lns revision $1\n";
	77	} else {
	78	print "lns: unknown revision\n";
	79	}
	80	exit 0;
	81	} elsif ($1 eq "-licence" or $1 eq "-license") {
	82	print $licence;
	83	exit 0;
	84	} else {
	85	foreach $opt (split //, $1) {
	86	if ($opt eq "a") { $abs=1; }
	87	elsif ($opt eq "f") { $force=1; }
	88	elsif ($opt eq "q") { $quiet=1; }
53ddbe1a	89	elsif ($opt eq "r") { $recurse=1; }
337ff285	90	elsif ($opt eq "v") { $verbose++; }
337ff285	91	elsif ($opt eq "F") { $force=$FILE=1; }
5a303401	92	else { die "lns: unrecognised option '-$1'\n"; }
337ff285	93	}
	94	}
	95	}
	96
	97	die $usage if $#ARGV < 1;
	98
5a303401	99	die "lns: multiple source files specified with -F option\n"
337ff285	100	if $#ARGV > 1 && $FILE;
5a303401	101	die "lns: -q (quiet) and -v (verbose) options both specified\n"
337ff285	102	if $quiet && $verbose;
	103
	104	$target = pop @ARGV;
5a303401	105	die "lns: multiple source files specified, $target not a directory\n"
337ff285	106	if $#ARGV > 0 && !-d $target;
	107
	108	$multiple = (-d $target && !$FILE);
337ff285	109
	110	$target =~ s/// if $target =~ /\/$/; # strip trailing slash if present
	111
	112	if ($multiple) {
	113	foreach $source (@ARGV) {
9d63af99	114	# We must path-normalise $source _before_ looking for the final
	115	# filename component, to deal with the case of `lns . subdir'
	116	# in which we want the link to be called subdir/<dirname> rather
	117	# than subdir/. .
	118	$source = &normalise($source);
337ff285	119	$source =~ /^(.\/)?([^\/])$/; # find final file name component
	120	&makelink($source, "$target/$2"); # actually make a link
	121	}
	122	} else {
	123	$source = $ARGV[0]; # only one source file
	124	&makelink($source, $target); # make the link
	125	}
	126
	127	sub makelink {
	128	local ($source, $target) = @_;
124cdfbe	129	# Calculate the absolute path names of both source and target.
	130	$source = &normalise($source);
	131	$target = &normalise($target);
	132
	133	# If we're in Relative mode (the default), calculate the relative path
	134	# name we will reference the source by.
	135	$sourcename = $abs ? $source : &relname($source, $target);
	136
53ddbe1a	137	my $donothing = 0;
	138	my $recursing = $recurse && -d $source;
	139	my $ok;
337ff285	140	# If the target exists...
337ff285	141	if (-e $target \|\| readlink $target) {
53ddbe1a	142	if ($recursing && -d $target) {
	143	# If it's a directory and we're in recursive mode, just do nothing
	144	# and work around it.
	145	$donothing = 1;
	146	} elsif ($force && readlink $target) {
	147	# If it's a symlink and we're in Force mode, remove it and carry on.
5a303401	148	unlink $target \|\| die "lns: unable to remove link $target\n";
337ff285	149	# Report that if in Verbose mode.
5a303401	150	warn "lns: removing existing target link $target\n" if $verbose;
337ff285	151	} else {
337ff285	152	# Otherwise, fail. Report that fact if not in Quiet mode.
5a303401	153	warn "lns: failed to link $source to $target: target exists\n"
337ff285	154	if !$quiet;
	155	return;
	156	}
	157	}
	158
53ddbe1a	159	if ($recursing) {
	160	# Make the directory.
	161	if ($donothing) {
	162	warn "lns: directory $target already exists, no need to create it\n"
	163	if $verbose;
	164	$ok = 1;
	165	} else {
	166	warn "lns: making directory $target\n"
	167	if $verbose;
	168	if (mkdir $target) {
	169	$ok = 1;
	170	} else {
	171	warn "lns: unable to make directory '$target': $!\n";
	172	}
	173	}
	174	# Now recurse into it.
	175	if ($ok) {
	176	my $dh = POSIX::opendir($source);
	177	my @files = POSIX::readdir($dh);
	178	my $f;
	179	POSIX::closedir($dh);
	180	foreach $f (@files) {
	181	next if $f eq "." or $f eq "..";
	182	&makelink("$source/$f", "$target/$f");
	183	}
	184	}
	185	} else {
	186	# Make the link.
	187	warn "lns: linking $source: $target -> $sourcename\n" if $verbose;
	188	symlink($sourcename, $target) \|\| die "lns: unable to make link to $target\n";
	189	}
337ff285	190	}
337ff285	191
73bdc6aa	192	sub normalise {
	193	# Normalise a path into an absolute one containing no . or ..
	194	# segments.
	195	local ($_) = @_;
337ff285	196
124cdfbe	197	warn "lns: path normalisation required on $_\n" if $verbose > 2;
124cdfbe	198
73bdc6aa	199	# Make relative paths absolute.
73bdc6aa	200	$_ = getcwd() . "/" . $_ if !/^\//;
337ff285	201
73bdc6aa	202	# Remove "." segments.
73bdc6aa	203	1 while s/^(.)\/\.(\/.)?$/$1$2/;
337ff285	204
73bdc6aa	205	# Remove redundant slashes.
626fc36e	206	s/\/+/\//g;
337ff285	207
73bdc6aa	208	# Remove a trailing slash if present.
73bdc6aa	209	s/\/$//;
337ff285	210
73bdc6aa	211	# Remove ".." segments. This is the hard bit, because a
	212	# directory segment that's a _symlink_ doesn't do the obvious
	213	# thing if followed by "..". But we can't just call realpath,
	214	# because we do want to preserve symlinks where they _don't_
	215	# interfere with this sort of work. So the algorithm is:
337ff285	216	#
	217	# - Repeatedly search for the rightmost `directory/..'
	218	# fragment.
	219	# - When we find it, one of two cases apply.
	220	# * If the directory before the .. is not a symlink, we can
	221	# remove both it and the .. from the string.
	222	# * If it _is_ a symlink, we substitute it for its link
	223	# text, and loop round again.
73bdc6aa	224	while (/^(.)\/((\.\|\.\.[^\/]+\|\.?[^\/\.][^\/])\/\.\.)(\/.*)?$/)
337ff285	225	{
337ff285	226	my ($pre, $dir, $frag, $post) = ($1,$2,$3,$4);
124cdfbe	227	my $log = " transforming $_ -> ";
337ff285	228	if (-l "$pre/$frag") {
	229	my $linktext = readlink "$pre/$frag";
	230	if ($linktext =~ /^\//) { # absolute link
73bdc6aa	231	$_ = $linktext;
337ff285	232	} else { # relative link
73bdc6aa	233	$_ = "$pre/$linktext";
337ff285	234	}
73bdc6aa	235	$_ .= "/.." . $post;
337ff285	236	} else {
73bdc6aa	237	$_ = $pre . $post;
337ff285	238	}
73bdc6aa	239	$_ = "/" if $_ eq ""; # special case
626fc36e	240	s/\/+/\//g; # remove redundant slashes again in case link text had any
124cdfbe	241	$log .= "$_";
124cdfbe	242	warn "lns: $log\n" if $verbose > 2;
337ff285	243	}
337ff285	244
73bdc6aa	245	# The only place where a ".." fragment might still remain is at
	246	# the very start of the string, and "/.." is defined to be
	247	# equivalent to "/".
124cdfbe	248	1 while s/^\/\.\.(\/(.*))?$/\/$2/;
	249
	250	warn "lns: path normalisation returned $_\n" if $verbose > 2;
73bdc6aa	251
	252	return $_;
	253	}
	254
	255	sub relname {
	256	local ($source, $target) = @_;
	257	local $prefix;
	258
	259	# Strip the last word off the target (the actual file name) to
	260	# obtain the target _directory_.
	261	$target =~ s/\/[^\/]*$//;
	262
	263	# Our starting prefix is empty. We will add one "../" at a time
	264	# until we find a match.
	265
	266	while (1) {
	267
124cdfbe	268	warn "lns: trying prefix '$prefix': looking for $target as prefix of $source\n" if $verbose > 1;
124cdfbe	269
a6aa7104	270	# If $target is _precisely_ $source, we are done.
	271	if ($target eq $source) {
	272	return "." if $prefix eq "";
	273	$prefix =~ s/\/$//;
	274	return $prefix;
	275	}
	276
73bdc6aa	277	# If $target is a prefix of $source, we are done. (No matter what
	278	# symlinks may exist on the shared common pathname, if we are
	279	# linking `a/b/c/foo' to `foo' then a simple relative link will
	280	# work.)
	281	if (substr($source, 0, 1 + length $target) eq "$target/") {
124cdfbe	282	warn "lns: found it\n" if $verbose > 1;
	283	return $prefix . substr($source, 1 + length $target); # skip the slash
	284	} elsif ($target eq "/") {
	285	warn "lns: found it\n" if $verbose > 1;
	286	return $prefix . substr($source, 1); # special case
73bdc6aa	287	}
	288
	289	# Otherwise, descend to "..".
	290	$target = &normalise($target . "/..");
	291
337ff285	292	# Now we have replaced $target with a pathname equivalent to
	293	# `$target/..'. So add a "../" to $prefix, and try matching
	294	# again.
	295	$prefix .= "../";
	296	}
	297	}