#!/usr/bin/perl require 5; $VERSION = '2.01'; # Time-stamp: "2004-08-20 00:36:42 ADT" =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 to make symlinks. So use this program, F, instead -- it's basically F plus lots of sanity-checking and DWIM ("do what I mean"). Notably, it doesn't care whether you say C or C. =head1 EXAMPLE USES Here's a short example session containing attempts to use F 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, which prints the lns version number and aborts. =head1 SEE ALSO The man page for F. =head1 BUG REPORTS If this program acts up, email me about it, at C. =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 and L.) 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. =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 #=========================================================================== 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__