dh_link

   1 #!/usr/bin/perl -w
   2
   3 =head1 NAME
   4
   5 dh_link - create symlinks in package build directories
   6
   7 =cut
   8
   9 use strict;
  10 use File::Find;
  11 use Debian::Debhelper::Dh_Lib;
  12
  13 =head1 SYNOPSIS
  14
  15 B<dh_link> [S<I<debhelper options>>] [B<-A>] [B<-X>I<item>] [S<I<source destination ...>>]
  16
  17 =head1 DESCRIPTION
  18
  19 dh_link is a debhelper program that creates symlinks in package build
  20 directories.
  21
  22 dh_link accepts a list of pairs of source and destination files. The source
  23 files are the already existing files that will be symlinked from. The
  24 destination files are the symlinks that will be created. There B<must> be
  25 an equal number of source and destination files specified.
  26
  27 The list can be specified in two ways. A file named debian/package.links
  28 can list pairs of files. If you use this file, you should put each pair
  29 of files on its own line, and separate the files within the pair with
  30 whitespace. Also, pairs of files can be specified as parameters - these
  31 pairs will only be created in the package build directory of the first
  32 package dh_link is told to act on. By default, this is the first binary
  33 package in debian/control, but if you use -p, -i, or -a flags, it will be
  34 the first package specified by those flags.
  35
  36 Be sure you B<do> specify the full filename to both the source and
  37 destination files (unlike you would do if you were using something like
  38 L<ln(1)>).
  39
  40 dh_link will generate symlinks that comply with debian policy - absolute
  41 when policy says they should be absolute, and relative links with as short
  42 a path as possible. It will also create any subdirectories it needs to to put
  43 the symlinks in.
  44
  45 dh_link also scans the package build tree for existing symlinks which do not
  46 conform to debian policy, and corrects them (v4 or later).
  47
  48 =head1 OPTIONS
  49
  50 =over 4
  51
  52 =item B<-A>, B<--all>
  53
  54 Create any links specified by command line parameters in ALL packages
  55 acted on, not just the first.
  56
  57 =item B<-Xitem>, B<--exclude=item>
  58
  59 Do not correct symlinks that contain "item" anywhere in their filename from
  60 being corrected to comply with debian policy.
  61
  62 =item I<source destination ...>
  63
  64 Create a file named "destination" as a link to a file named "source". Do
  65 this in the package build directory of the first package acted on.
  66 (Or in all packages if -A is specified.)
  67
  68 =back
  69
  70 =head1 EXAMPLES
  71
  72  dh_link usr/share/man/man1/foo.1 usr/share/man/man1/bar.1
  73
  74 Make bar.1 be a symlink to foo.1
  75
  76  dh_link var/lib/foo usr/lib/foo \
  77    usr/share/man/man1/foo.1 usr/share/man/man1/bar.1
  78
  79 Make /usr/lib/foo/ be a link to /var/lib/foo/, and bar.1 be a symlink to
  80 the foo.1
  81
  82 =cut
  83
  84 # This expand_path expands all path "." and ".." components, but doesn't
  85 # resolve symbolic links.
  86 sub expand_path {
  87         my $start = @_ ? shift : '.';
  88         my @pathname = split(m:/+:,$start);
  89
  90         my $entry;
  91         my @respath;
  92         foreach $entry (@pathname) {
  93                 if ($entry eq '.' || $entry eq '') {
  94                         # Do nothing
  95                 }
  96                 elsif ($entry eq '..') {
  97                         if ($#respath == -1) {
  98                                 # Do nothing
  99                         }
 100                         else {
 101                                 pop @respath;
 102                         }
 103                 }
 104                 else {
 105                         push @respath, $entry;
 106                 }
 107         }
 108
 109         my $result;
 110         foreach $entry (@respath) {
 111                 $result .= '/' . $entry;
 112         }
 113         if (! defined $result) {
 114                 $result="/"; # special case
 115         }
 116         return $result;
 117 }
 118
 119
 120 init();
 121
 122 foreach my $package (@{$dh{DOPACKAGES}}) {
 123         my $tmp=tmpdir($package);
 124         my $file=pkgfile($package,"links");
 125
 126         my @links;
 127         if ($file) {
 128                 @links=filearray($file);
 129         }
 130
 131         # Make sure it has pairs of symlinks and destinations. If it
 132         # doesn't, $#links will be _odd_ (not even, -- it's zero-based).
 133         if (int($#links/2) eq $#links/2) {
 134                 error("$file lists a link without a destination.");
 135         }
 136
 137         if (($package eq $dh{FIRSTPACKAGE} || $dh{PARAMS_ALL}) && @ARGV) {
 138                 push @links, @ARGV;
 139         }
 140
 141         # Same test as above, including arguments this time.
 142         if (int($#links/2) eq $#links/2) {
 143                 error("parameters list a link without a destination.");
 144         }
 145
 146         # v4 or later and only if there is a temp dir already
 147         if (! compat(3) && -e $tmp) {
 148                 # Scan for existing links and add them to @links, so they
 149                 # are recreated policy conformant.
 150                 find(
 151                         sub {
 152                                 return unless -l;
 153                                 return if excludefile($_);
 154                                 my $dir=$File::Find::dir;
 155                                 $dir=~s/^\Q$tmp\E//;
 156                                 my $target = readlink($_);
 157                                 if ($target=~/^\//) {
 158                                         push @links, $target;
 159                                 }
 160                                 else {
 161                                         push @links, "$dir/$target";
 162                                 }
 163                                 push @links, "$dir/$_";
 164
 165                         },
 166                         $tmp);
 167         }
 168
 169         while (@links) {
 170                 my $dest=pop @links;
 171                 my $src=expand_path(pop @links);
 172
 173                 $src=~s:^/::;
 174                 $dest=~s:^/::;
 175
 176                 if ($src eq $dest) {
 177                         warning("skipping link from $src to self");
 178                         next;
 179                 }
 180
 181                 # Make sure the directory the link will be in exists.
 182                 my $basedir=dirname("$tmp/$dest");
 183                 if (! -e $basedir) {
 184                         doit("install","-d",$basedir);
 185                 }
 186
 187                 # Policy says that if the link is all within one toplevel
 188                 # directory, it should be relative. If it's between
 189                 # top level directories, leave it absolute.
 190                 my @src_dirs=split(m:/+:,$src);
 191                 my @dest_dirs=split(m:/+:,$dest);
 192                 if (@src_dirs > 0 && $src_dirs[0] eq $dest_dirs[0]) {
 193                         # Figure out how much of a path $src and $dest
 194                         # share in common.
 195                         my $x;
 196                         for ($x=0; $x < @src_dirs && $src_dirs[$x] eq $dest_dirs[$x]; $x++) {}
 197                         # Build up the new src.
 198                         $src="";
 199                         for (1..$#dest_dirs - $x) {
 200                                 $src.="../";
 201                         }
 202                         for ($x .. $#src_dirs) {
 203                                 $src.=$src_dirs[$_]."/";
 204                         }
 205                         if ($x > $#src_dirs && ! length $src) {
 206                                 $src.="."; # special case
 207                         }
 208                         $src=~s:/$::;
 209                 }
 210                 else {
 211                         # Make sure it's properly absolute.
 212                         $src="/$src";
 213                 }
 214
 215                 if (-d "$tmp/$dest" && ! -l "$tmp/$dest") {
 216                         error("link destination $tmp/$dest is a directory");
 217                 }
 218                 doit("rm", "-f", "$tmp/$dest");
 219                 doit("ln","-sf", $src, "$tmp/$dest");
 220         }
 221 }
 222
 223 =head1 SEE ALSO
 224
 225 L<debhelper(7)>
 226
 227 This program is a part of debhelper.
 228
 229 =head1 AUTHOR
 230
 231 Joey Hess <joeyh@debian.org>
 232
 233 =cut