#!/usr/bin/perl
# $Id: fixlinks,v 1.7 2001/04/23 17:51:09 opr Exp $
# A relative to absolute symlink converter.
# Copyright 1999 by Timo Korvola.

use strict;
use vars qw($verbose $testrun $depth);

sub usage {
  print
    "Usage: fixlinks [-qnv] [-d n] link1 ...

Replaces symlink targets that start with one or more \"../\"'s with absolute
filenames.  Any \"..\"'s not at the beginning of the link target will remain.

Non-option arguments should be absolute filenames of symlinks.  If
not, a warning is triggered and the invalid argument is otherwise
ignored.  Trailing slashes in the arguments are ignored.

The provided name is used to interpret the \"..\"'s in the beginning
of the link target.  Note that this may change the actual target
location of the link if the given path contains symlinks.  This is
intentional and useful, as fixlinks is mainly intended to be used for
repairing broken links left by a well-meaning but clueless software
installer, e.g., rpm -ql foo | xargs fixlinks -v.

If the link target does not start with \"../\" it is left unmodified.
If -d n is specified, where n is a non-negative integer, only
links that back up to nth level directories or above are changed (the root
directory is 0th level).  E.g., with -d 0 a link /usr/lib/libc.so ->
../../lib/libc.so would be changed to point to /lib/libc.so while
/usr/lib/sendmail -> ../sbin/sendmail would remain unchanged.  With -d 1 both
links would be changed.

Warnings can be suppressed with the -q option.  -v causes changes to
be output.  The format is link -> old -> new.  With the -n option no
changes are actually performed and -v is implied.
";
  die "\n";
}


# fix_link link target
# link is an absolute file name for the link
# target is the original link target.
# returns the new and improved link target or '' if no change is needed.
sub fix_link {
  my @linkdir = split '/', $_[ 0];	# N.B. $linkdir[ 0] is ''.
  $#linkdir--;
  my @targ = split '/', $_[ 1];

  return '' unless $targ[ 0] eq '..';
  do {
    $#linkdir-- > 0 or die "$_[ 0] -> $_[ 1]: too many \"..\"'s.\n";
    shift @targ;
  } while ($targ[ 0] eq '..');
  return (defined $depth) && $#linkdir > $depth ?
    '' : join '/', (@linkdir, @targ);
}


use Getopt::Std;

# Main
my (%opts, $targ, $link, $newtarg);
getopt 'd', \%opts;
foreach (keys %opts) {
  $_ eq 'q' and $SIG{'__WARN__'} = sub {}, next;
  $_ eq 'n' and $verbose = 1, $testrun = 1, next;
  $_ eq 'v' and $verbose = 1, next;
  if ($_ eq 'd') {
    $depth = $opts{'d'};
    $depth =~ /^\d+$/ or die "Invalid number for -d: $depth.\n";
    next;
  }
  print STDERR "Unknown option $_.\n";
  usage;
}
usage if $#ARGV < 0;
foreach (@ARGV) {
  s'/$'';
  (warn "$_ is not an absolute filename.\n"), next unless m+^/+;
  (warn "$_ is not a symbolic link.\n"), next unless -l;
  $targ = readlink or die "Cannot readlink $_: $!\n";
  unless ($newtarg = fix_link $link = $_, $targ) {
    print "$link -> $targ    (unchanged)\n" if $verbose;
    next;
  }

  print "$link -> $targ -> $newtarg\n" if $verbose;
  next if $testrun;
  unlink $link or die "Cannot unlink $link: $!\n";
  symlink $newtarg, $link or die "Cannot symlink $link -> $newtarg: $!\n";
}