Instantly share code, notes, and snippets.

What would you like to do?
Perl source code for lns utility (archived)
# desc{ a friendly program for making symbolic links }
$VERSION = '2.01'; # Time-stamp: "2008-08-19 19:26:35 AKDT"
=head1 NAME
lns -- a friendly program for making symbolic links
lns target-filespec symlink-filespec
lns symlink-filespec target-filespec
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>.
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>.
If this program acts up, email me about it, at C<>.
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<>.
=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.
require 5;
if( @ARGV and $ARGV[0] eq '-v' ) {
print "lns v$VERSION sburke\\n";
} 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<^(.*/)[^/]+$>) {
"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";
# "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";
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";
# 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;
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 '..') {
if($i == 0) {
shift @$b; # just nix myself and run
} else {
splice @$b, $i-1, 2;
} elsif($b->[$i] eq '.') {
shift @$b; # just nix myself and run
} else {
# Normal path bit.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment