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