debian/fixlinks

   1 #!/usr/bin/perl -w
   2 # vi: set ts=4:
   3
   4
   5 @LINKS=`find . -type l|xargs ls -l`;
   6
   7 #print @LINKS;
   8
   9
  10 while($_ = shift @LINKS){
  11         chomp;
  12         my ($perm,$nlinks,$owner,$group,$size,$month,$day,$year,$file) =
  13                 split(' ', $_, 9);
  14         my $link;
  15
  16         if($perm =~ m/^l/){
  17                 ($relfile, $link) = split(' -> ', $file);
  18         }
  19
  20         # chop off leading . in $file
  21         $file = $relfile;
  22         $file =~ s/^\.//;
  23
  24         if($perm =~ m/^l/){
  25                 my @pathcomponents = split('/', $file);
  26                 my @linkcomponents = split('/', $link);
  27
  28                 if($link =~ m/^\//){
  29                         @newcomponents = @linkcomponents;
  30                 }else{
  31                         @newcomponents = @pathcomponents;
  32
  33                         # chop off filename
  34                         pop(@newcomponents);
  35
  36                         while($comp = shift @linkcomponents){
  37                                 #print "path: ",join(':',@newcomponents)," -- $comp -- ", join(':',@linkcomponents),"\n";
  38
  39                                 if($comp eq ""){
  40                                         # ignore
  41                                 }elsif($comp eq ".."){
  42                                         pop(@newcomponents);
  43                                 }else{
  44                                         push @newcomponents,$comp;
  45                                 }
  46                         }
  47                 }
  48
  49                 if($newcomponents[0] eq ""){
  50                         shift(@newcomponents);
  51                 }
  52                 if($pathcomponents[0] eq ""){
  53                         shift(@pathcomponents);
  54                 }
  55
  56                 #print "from ",join('/',@pathcomponents),"\n";
  57                 #print "to ",join('/',@newcomponents),"\n";
  58
  59                 if($newcomponents[0] eq $pathcomponents[0]){
  60                         #print $newcomponents[0],", ",$pathcomponents[0];
  61                         #print "should be relative\n";
  62                         while($newcomponents[0] eq $pathcomponents[0]){
  63                                 shift(@newcomponents);
  64                                 shift(@pathcomponents);
  65                         }
  66                         while(@pathcomponents > 1){
  67                                 shift(@pathcomponents);
  68                                 unshift(@newcomponents,"..");
  69                         }
  70                 }else{
  71                         #print "should be absolute\n";
  72                         unshift(@newcomponents,"");
  73                 }
  74                 $newlink=join('/',@newcomponents);
  75                 print "ln -sf $newlink $relfile\n";
  76                 unlink($relfile);
  77                 symlink($newlink,$relfile);
  78         }
  79 }
  80