# 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".
"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" .
"CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE\n" .
"SOFTWARE.\n";
-$abs=$force=$quiet=$verbose=$FILE=0;
+$abs=$force=$quiet=$verbose=$recurse=$FILE=0;
while ($_=shift @ARGV) {
last if /^--$/;
unshift (@ARGV, $_), last unless /^-(.*)/;
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 "$0: unrecognised option '-$1'\n"; }
+ else { die "lns: unrecognised option '-$1'\n"; }
}
}
}
die $usage if $#ARGV < 1;
-die "$0: multiple source files specified with -F option\n"
+die "lns: multiple source files specified with -F option\n"
if $#ARGV > 1 && $FILE;
-die "$0: -q (quiet) and -v (verbose) options both specified\n"
+die "lns: -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"
+die "lns: 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) {
+ # 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
}
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 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";
+ 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 "$0: removing existing target link $target\n" if $verbose;
+ warn "lns: 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"
+ warn "lns: 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";
+ 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 absolute {
- local ($_) = @_;
- $_ = "$whereami/$_" if !/^\//;
- s//$whereami/ if /^\./;
- 1 while s/\/\.\//\//;
- 1 while s/\/\//\//;
- 1 while s/\/[^\/]+\/\.\.//;
- 1 while s/^\/\.\.\//\//;
- $_;
-}
+sub normalise {
+ # Normalise a path into an absolute one containing no . or ..
+ # segments.
+ local ($_) = @_;
-sub relname {
- local ($source, $target) = @_;
- local $prefix;
+ warn "lns: path normalisation required on $_\n" if $verbose > 2;
- # Strip the last word off the target (the actual file name) to
- # obtain the target _directory_.
- $target =~ s/\/[^\/]*$//;
+ # Make relative paths absolute.
+ $_ = getcwd() . "/" . $_ if !/^\//;
- # Our starting prefix is empty. We will add one "../" at a time
- # until we find a match.
+ # Remove "." segments.
+ 1 while s/^(.*)\/\.(\/.*)?$/$1$2/;
- while (1) {
+ # Remove redundant slashes.
+ s/\/+/\//g;
- # 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
- }
+ # Remove a trailing slash if present.
+ s/\/$//;
- # 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:
+ # 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.
# 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 =~
- /^(.*)\/((\.|\.\.[^\/]+|\.?[^\/\.][^\/]*)\/\.\.)(\/.*)?$/)
+ while (/^(.*)\/((\.|\.\.[^\/]+|\.?[^\/\.][^\/]*)\/\.\.)(\/.*)?$/)
{
my ($pre, $dir, $frag, $post) = ($1,$2,$3,$4);
- my $log = "transforming $target -> ";
+ my $log = " transforming $_ -> ";
if (-l "$pre/$frag") {
my $linktext = readlink "$pre/$frag";
if ($linktext =~ /^\//) { # absolute link
- $target = $linktext;
+ $_ = $linktext;
} else { # relative link
- $target = "$pre/$linktext";
+ $_ = "$pre/$linktext";
}
- $target .= "/.." . $post;
+ $_ .= "/.." . $post;
} else {
- $target = $pre . $post;
+ $_ = $pre . $post;
}
- $target = "/" if $target eq ""; # special case
- $log .= "$target";
- warn "$0: $log\n" if $verbose > 1;
+ $_ = "/" 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.
~mdw / sgt / utils / blobdiff