| #!/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