Skip to content

Instantly share code, notes, and snippets.

@tommorris tommorris/lns.pm
Created Aug 30, 2017

Embed
What would you like to do?
Perl source code for lns utility (archived)
#!/usr/bin/perl
# desc{ a friendly program for making symbolic links }
$VERSION = '2.01'; # Time-stamp: "2008-08-19 19:26:35 AKDT sburke@cpan.org"
=head1 NAME
lns -- a friendly program for making symbolic links
=head1 SYNOPSIS
lns target-filespec symlink-filespec
or
lns symlink-filespec target-filespec
=head1 DESCRIPTION
It's easy to make mistakes when you're using F<ln -s> to make
symlinks. So use this program, F<lns>, instead -- it's basically F<ln
-s> plus lots of sanity-checking and DWIM ("do what I mean").
Notably, it doesn't care whether you say C<lns target symlink> or
C<lns symlink target>.
=head1 EXAMPLE USES
Here's a short example session containing attempts to use F<lns> to make
some symlinks:
% ls -l
-rw-r--r-- 1 sburke dongs 5235 Feb 29 20:52 stuff.html
% lns stuff.html index.html
Made index.html -> stuff.html
% ls -l
lrwxr-xr-x 1 sburke dongs 10 Feb 29 22:43 index.html -> stuff.html
-rw-r--r-- 1 sburke dongs 5235 Aug 19 22:43 stuff.html
% lns funk.txt fank.dat
But neither funk.txt nor fank.dat exist!
% lns index.html stuff.html
But both index.html and stuff.html already exist.
Maybe rm the symlink index.html (->stuff.html)?
% lns . foo
lns doesn't allow symlinking to or from "."
=head1 OPTIONS
Currently, the only command-line option is C<lns -v>, which prints the
lns version number and aborts.
=head1 SEE ALSO
The man page for F<ln>.
=head1 BUG REPORTS
If this program acts up, email me about it, at C<sburke@cpan.org>.
=head1 COPYRIGHT AND DISCLAIMER
Copyright (c) 2004 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
(See L<perlartistic> and L<perlgpl>.)
The program and its documentation are distributed in the hope that
they will be useful, but without any warranty; without even the
implied warranty of merchantability or fitness for a particular
purpose. But let me know if it gives you trouble, okay?
=head1 AUTHOR
Sean M. Burke, C<sburke@cpan.org>.
=head1 SCRIPT CATEGORIES
UNIX/System_administration
=head1 CHANGE LOG
=over
=item v2.01 2004-08-20
First CPAN release, after maybe four years of using it on my own and
passing it around to friends. All that's new in this version is the
documentation, and the "-v" option.
=back
=cut
require 5;
#===========================================================================
if( @ARGV and $ARGV[0] eq '-v' ) {
print "lns v$VERSION sburke\x40cpan.org\n";
exit;
} elsif( @ARGV != 2) {
die "Usage: lns symlink_to_make source_filespec (or vice versa)\n",
" See 'perldoc lns' for more information.\n",
}
use strict;
#--------------------------------------------------------------------------
sub DEBUG () {0}
my($from, $to) = @ARGV;
# $from is the spec of the link to make.
# $to is what it should point to.
die "Can't use empty-string as a filespec.\n"
unless length $from and length $to;
die "But source and target are the same ($from)!" if $from eq $to;
foreach my $x ($from, $to) {
if($x =~ s</+$><>s) { # kill trailing /'s
$x = '/' if $x eq '';
}
}
die "lns doesn't allow symlinking to or from \"..\"\n"
if $to eq '..' or $from eq '..';
die "lns doesn't allow symlinking to or from \".\"\n"
if $to eq '.' or $from eq '.';
# Technically, it'd be possible to link anything TO . or ..,
# but it's so icky I'll disallow it.
# Assert that $from doesn't exist and $to exists; and $to's not
# a symlink, nor '.' nor '..'
if(-e $from or -l $from) {
# Why not just "-e $from"? because "-e $from" is false if $from
# is a dangling symlink
#
if(-e $to or -l $to) {
# They both exist!
if(-l $from) {
if(-l $to) {
die "But both $from and $to already exist, and are both symlinks!\n";
} else {
die "But both $from and $to already exist.\nMaybe rm the symlink $from (->",
readlink($from), ")?\n";
}
} else {
if(-l $to) {
die "But both $from and $to already exist.\nMaybe rm the symlink $to (->",
readlink($to), ")?\n";
} else {
die "But both $from and $to already exist, and neither are symlinks.\n";
}
}
} else {
# One exists, the other doesn't, but they need switching.
($from, $to) = ($to, $from);
}
} else {
# $from doesn't exist
if(-e $to or -l $to) {
# One exists, the other doesn't, and they're each in the right place.
} else {
die "But neither $from nor $to exist!\n";
}
}
# If we're putting the symlink somewhere else, make sure
# the directory we want to put it in exists.
if($from =~ m<^(.*/)[^/]+$>) {
die
"But the directory $1 doesn't exist for the symlink $from to be put in!\n"
unless -e $1;
# Altho it may actually be a dangling symlink. Not our problem, really.
}
if($from =~ m</> and $to !~ m<^/>) {
# The $from is in another dir, and the $to is relative.
# We /expect/ the $to to be interpreted relative to the pwd.
# However, we'll need to re-relativize it for sake of symlinking,
# so we can have a pathspec to it that's relative to $from's base
# directory.
# If it turns out that interpreting original $to relative to
# $from's base dir gives us an existing file too, then scream,
# in case the user's mixed up as to which is meant.
# However, note that unless $to (relative to pwd) existed, we'd
# never have gotten this far!
# This is all a bit of a mess, and if I had it to do over again,
# I might just make this refuse to deal with $froms in other dirs
# unless $to is absolute. I don't know if that's detectable, tho,
# since all the "what exists / what doesn't" code, above, already
# assumes that relative things are relative to PWD.
my $f_dir = $from;
my $f_base;
if($f_dir =~ s</([^/]+)$><>) {
$f_base = $1;
$f_dir = '/' unless length $f_dir;
} else {
die "SNORT";
}
my $pwd = `pwd`;
chomp $pwd;
$pwd = abs2rel($pwd, '/');
my $f_dir_abs = rel2abs($f_dir, $pwd);
DEBUG and print "f_dir_abs: [$f_dir_abs] pwd: [$pwd]\n";
my $to_abs = rel2abs($to, $f_dir_abs);
my $to_alt_abs = rel2abs($to, $pwd);
my $to_alt_rel = abs2rel($to_alt_abs, $f_dir_abs);
if(-e $to_abs or -l $to_abs) {
die "Does \"$to\" refer to $to_alt_abs or $to_abs? Both exist.\n",
"Depending on which you mean, run one of these:\n",
" cd $f_dir; lns $f_base $to\n", # if rel to $f_dir_abs
" or: cd $f_dir; lns $f_base $to_alt_rel\n", # if rel to $pwd
;
} else {
# It's not really ambiguous -- the other reading doesn't refer
# to an existing file.
print "(From $from\'s perspective, \"$to\" is \"$to_alt_rel\")\n";
$to = $to_alt_rel;
}
}
# Now actually do it
if( symlink($to, $from) ) {
print "Made $from -> $to\n";
} else {
die "Couldn't make symlink from $from to $to: $!\n";
}
exit;
# "It isn't necessary to imagine the world ending in fire or ice -- there are
# two other possibilities: one is paperwork, and the other is nostalgia."
# -- Frank Zappa
#...........................................................................
#
# The subs below here are of my own devising. For real
# things, use File::PathConvert from CPAN.
sub rel2abs {
# a bit of a hack?
my($spec, $base) = @_;
$base = '' if $spec =~ m<^/>;
my @bits = grep length $_, split m</+>, "$base/$spec";
DEBUG and print "rel2abs stack: [@bits]\n";
_dirlist_proc(\@bits);
DEBUG and print " outstack: [@bits]\n";
return '/' unless @bits;
return join '/', '', @bits;
}
sub abs2rel {
my($spec, $base) = @_;
return $spec unless $spec =~ m<^/>s; # sanity?
die "Base <$base> isn't absolute" unless $base =~ m<^/>s;
return $spec if $base eq '/'; # more sanity
my @spec = grep length $_, split m</+>, $spec;
my @base = grep length $_, split m</+>, $base;
DEBUG and print "1- base [@base] spec [@spec]\n";
_dirlist_proc(\@base);
_dirlist_proc(\@spec);
# eat away common initial parts. Assumes no parts are ".."!
my $cut_out;
while(@base and @spec and $base[0] eq $spec[0]) {
shift @base; shift @spec;
++$cut_out;
}
return join '/', '', @spec unless $cut_out;
# They had nothing in common. Return an absolute ref, I guess.
# Otherwise cdup to common dir, then have spec bits to go down again.
unshift @spec, ('..') x scalar(@base);
DEBUG and print "2- base [@base] spec [@spec]\n";
return '.' unless @spec;
return join '/', @spec;
}
sub _dirlist_proc {
my $b = $_[0];
for(my $i = 0; $i < @$b;) {
if($b->[$i] eq '..') {
# CDUP
if($i == 0) {
shift @$b; # just nix myself and run
} else {
splice @$b, $i-1, 2;
--$i;
}
} elsif($b->[$i] eq '.') {
# IDEM
shift @$b; # just nix myself and run
} else {
# Normal path bit.
++$i;
}
}
}
#---------------------------------------------------------------------------
__END__
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.
You signed in with another tab or window. Reload to refresh your session. You signed out in another tab or window. Reload to refresh your session.