scripts/dpkg-divert.pl

   1 #!/usr/bin/perl
   2 #
   3 # dpkg-divert
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 BEGIN { # Work-around for bug #479711 in perl
  19     $ENV{PERL_DL_NONLAZY} = 1;
  20 }
  21
  22 use strict;
  23 use warnings;
  24
  25 use POSIX qw(:errno_h);
  26 use Dpkg;
  27 use Dpkg::Gettext;
  28
  29 textdomain("dpkg");
  30
  31 sub version {
  32     printf _g("Debian %s version %s.\n"), $progname, $version;
  33
  34     printf _g("
  35 Copyright (C) 1995 Ian Jackson.
  36 Copyright (C) 2000,2001 Wichert Akkerman.");
  37
  38     printf _g("
  39 This is free software; see the GNU General Public Licence version 2 or
  40 later for copying conditions. There is NO warranty.
  41 ");
  42 }
  43
  44 sub usage {
  45     printf(_g(
  46 "Usage: %s [<option> ...] <command>
  47
  48 Commands:
  49   [--add] <file>           add a diversion.
  50   --remove <file>          remove the diversion.
  51   --list [<glob-pattern>]  show file diversions.
  52   --listpackage <file>     show what package diverts the file.
  53   --truename <file>        return the diverted file.
  54
  55 Options:
  56   --package <package>      name of the package whose copy of <file> will not
  57                              be diverted.
  58   --local                  all packages' versions are diverted.
  59   --divert <divert-to>     the name used by other packages' versions.
  60   --rename                 actually move the file aside (or back).
  61   --admindir <directory>   set the directory with the diversions file.
  62   --test                   don't do anything, just demonstrate.
  63   --quiet                  quiet operation, minimal output.
  64   --help                   show this help message.
  65   --version                show the version.
  66
  67 When adding, default is --local and --divert <original>.distrib.
  68 When removing, --package or --local and --divert must match if specified.
  69 Package preinst/postrm scripts should always specify --package and --divert.
  70 "), $progname);
  71 }
  72
  73 my $testmode = 0;
  74 my $dorename = 0;
  75 my $verbose = 1;
  76 my $mode = '';
  77 my $package = undef;
  78 my $divertto = undef;
  79 my @contest;
  80 my @altname;
  81 my @package;
  82 my $file;
  83 $|=1;
  84
  85
  86 # FIXME: those should be local.
  87 my ($rsrc, $rdest);
  88 my (@ssrc, @sdest);
  89
  90 sub checkmanymodes {
  91     return unless $mode;
  92     badusage(sprintf(_g("two commands specified: %s and --%s"), $_, $mode));
  93 }
  94
  95 while (@ARGV) {
  96     $_= shift(@ARGV);
  97     last if m/^--$/;
  98     if (!m/^-/) {
  99         unshift(@ARGV,$_); last;
 100     } elsif (m/^--help$/) {
 101         usage();
 102         exit(0);
 103     } elsif (m/^--version$/) {
 104         version();
 105         exit(0);
 106     } elsif (m/^--test$/) {
 107         $testmode= 1;
 108     } elsif (m/^--rename$/) {
 109         $dorename= 1;
 110     } elsif (m/^--quiet$/) {
 111         $verbose= 0;
 112     } elsif (m/^--local$/) {
 113         $package= ':';
 114     } elsif (m/^--add$/) {
 115         checkmanymodes();
 116         $mode= 'add';
 117     } elsif (m/^--remove$/) {
 118         checkmanymodes();
 119         $mode= 'remove';
 120     } elsif (m/^--list$/) {
 121         checkmanymodes();
 122         $mode= 'list';
 123     } elsif (m/^--listpackage$/) {
 124         checkmanymodes();
 125         $mode= 'listpackage';
 126     } elsif (m/^--truename$/) {
 127         checkmanymodes();
 128         $mode= 'truename';
 129     } elsif (m/^--divert$/) {
 130         @ARGV || badusage(sprintf(_g("--%s needs a divert-to argument"), "divert"));
 131         $divertto= shift(@ARGV);
 132         $divertto =~ m/\n/ && badusage(_g("divert-to may not contain newlines"));
 133     } elsif (m/^--package$/) {
 134         @ARGV || badusage(sprintf(_g("--%s needs a <package> argument"), "package"));
 135         $package= shift(@ARGV);
 136         $package =~ m/\n/ && badusage(_g("package may not contain newlines"));
 137     } elsif (m/^--admindir$/) {
 138         @ARGV || badusage(sprintf(_g("--%s needs a <directory> argument"), "admindir"));
 139         $admindir= shift(@ARGV);
 140     } else {
 141         badusage(sprintf(_g("unknown option \`%s'"), $_));
 142     }
 143 }
 144
 145 $mode='add' unless $mode;
 146
 147 open(O, "$admindir/diversions") || quit(sprintf(_g("cannot open diversions: %s"), $!));
 148 while(<O>) {
 149     s/\n$//; push(@contest,$_);
 150     $_ = <O>;
 151     s/\n$// || badfmt(_g("missing altname"));
 152     push(@altname,$_);
 153     $_ = <O>;
 154     s/\n$// || badfmt(_g("missing package"));
 155     push(@package,$_);
 156 }
 157 close(O);
 158
 159 if ($mode eq 'add') {
 160     @ARGV == 1 || badusage(sprintf(_g("--%s needs a single argument"), "add"));
 161     $file= $ARGV[0];
 162     $file =~ m#^/# || badusage(sprintf(_g("filename \"%s\" is not absolute"), $file));
 163     $file =~ m/\n/ && badusage(_g("file may not contain newlines"));
 164     -d $file && badusage(_g("Cannot divert directories"));
 165     $divertto= "$file.distrib" unless defined($divertto);
 166     $divertto =~ m#^/# || badusage(sprintf(_g("filename \"%s\" is not absolute"), $divertto));
 167     $package= ':' unless defined($package);
 168     for (my $i = 0; $i <= $#contest; $i++) {
 169         if ($contest[$i] eq $file || $altname[$i] eq $file ||
 170             $contest[$i] eq $divertto || $altname[$i] eq $divertto) {
 171             if ($contest[$i] eq $file && $altname[$i] eq $divertto &&
 172                 $package[$i] eq $package) {
 173                 printf(_g("Leaving \`%s'")."\n", infon($i)) if $verbose > 0;
 174                 exit(0);
 175             }
 176             quit(sprintf(_g("\`%s' clashes with \`%s'"), infoa(), infon($i)));
 177         }
 178     }
 179     push(@contest,$file);
 180     push(@altname,$divertto);
 181     push(@package,$package);
 182     printf(_g("Adding \`%s'")."\n", infon($#contest)) if $verbose > 0;
 183     checkrename($file, $divertto);
 184     save();
 185     dorename($file, $divertto);
 186     exit(0);
 187 } elsif ($mode eq 'remove') {
 188     @ARGV == 1 || badusage(sprintf(_g("--%s needs a single argument"), "remove"));
 189     $file= $ARGV[0];
 190     for (my $i = 0; $i <= $#contest; $i++) {
 191         next unless $file eq $contest[$i];
 192         quit(sprintf(_g("mismatch on divert-to\n  when removing \`%s'\n  found \`%s'"), infoa(), infon($i)))
 193               if defined($divertto) && $altname[$i] ne $divertto;
 194         quit(sprintf(_g("mismatch on package\n  when removing \`%s'\n  found \`%s'"), infoa(), infon($i)))
 195               if defined($package) && $package[$i] ne $package;
 196         printf(_g("Removing \`%s'")."\n", infon($i)) if $verbose > 0;
 197         my $orgfile = $contest[$i];
 198         my $orgdivertto = $altname[$i];
 199         @contest= (($i > 0 ? @contest[0..$i-1] : ()),
 200                    ($i < $#contest ? @contest[$i+1..$#contest] : ()));
 201         @altname= (($i > 0 ? @altname[0..$i-1] : ()),
 202                    ($i < $#altname ? @altname[$i+1..$#altname] : ()));
 203         @package= (($i > 0 ? @package[0..$i-1] : ()),
 204                    ($i < $#package ? @package[$i+1..$#package] : ()));
 205         checkrename($orgdivertto, $orgfile);
 206         dorename($orgdivertto, $orgfile);
 207         save();
 208         exit(0);
 209     }
 210     printf(_g("No diversion \`%s', none removed")."\n", infoa())
 211         if $verbose > 0;
 212     exit(0);
 213 } elsif ($mode eq 'list') {
 214     my @list;
 215     my @ilist = @ARGV ? @ARGV : ('*');
 216     while (defined($_=shift(@ilist))) {
 217         s/\W/\\$&/g;
 218         s/\\\?/./g;
 219         s/\\\*/.*/g;
 220         push(@list,"^$_\$");
 221     }
 222     my $pat = join('|', @list);
 223     for (my $i = 0; $i <= $#contest; $i++) {
 224         next unless ($contest[$i] =~ m/$pat/o ||
 225                      $altname[$i] =~ m/$pat/o ||
 226                      $package[$i] =~ m/$pat/o);
 227         print infon($i), "\n";
 228     }
 229     exit(0);
 230 } elsif ($mode eq 'truename') {
 231     @ARGV == 1 || badusage(sprintf(_g("--%s needs a single argument"), "truename"));
 232     $file= $ARGV[0];
 233     for (my $i = 0; $i <= $#contest; $i++) {
 234         next unless $file eq $contest[$i];
 235         print $altname[$i], "\n";
 236         exit(0);
 237     }
 238     print $file, "\n";
 239     exit(0);
 240 } elsif ($mode eq 'listpackage') {
 241     @ARGV == 1 || badusage(sprintf(_g("--%s needs a single argument"), $mode));
 242     $file= $ARGV[0];
 243     for (my $i = 0; $i <= $#contest; $i++) {
 244         next unless $file eq $contest[$i];
 245         if ($package[$i] eq ':') {
 246             # indicate package is local using something not in package namespace
 247             print "LOCAL\n";
 248         } else {
 249             print $package[$i], "\n";
 250         }
 251         exit(0);
 252     }
 253     # print nothing if file is not diverted
 254     exit(0);
 255 } else {
 256     quit(sprintf(_g("internal error - bad mode \`%s'"), $mode));
 257 }
 258
 259 sub infol {
 260     return ((defined($_[2]) ? ($_[2] eq ':' ? "local " : "") : "any ").
 261             "diversion of $_[0]".
 262             (defined($_[1]) ? " to $_[1]" : "").
 263             (defined($_[2]) && $_[2] ne ':' ? " by $_[2]" : ""));
 264 }
 265
 266 sub checkrename {
 267     return unless $dorename;
 268     ($rsrc,$rdest) = @_;
 269     (@ssrc = lstat($rsrc)) || $! == ENOENT ||
 270         quit(sprintf(_g("cannot stat old name \`%s': %s"), $rsrc, $!));
 271     (@sdest = lstat($rdest)) || $! == ENOENT ||
 272         quit(sprintf(_g("cannot stat new name \`%s': %s"), $rdest, $!));
 273     # Unfortunately we have to check for write access in both
 274     # places, just having +w is not enough, since people do
 275     # mount things RO, and we need to fail before we start
 276     # mucking around with things. So we open a file with the
 277     # same name as the diversions but with an extension that
 278     # (hopefully) wont overwrite anything. If it succeeds, we
 279     # assume a writable filesystem.
 280     if (open (TMP, ">>", "${rsrc}.dpkg-devert.tmp")) {
 281         close TMP;
 282         unlink ("${rsrc}.dpkg-devert.tmp");
 283     } elsif ($! == ENOENT) {
 284         $dorename = !$dorename;
 285         # If the source file is not present and we are not going to do the
 286         # rename anyway there's no point in checking the target.
 287         return;
 288     } else {
 289         quit(sprintf(_g("error checking \`%s': %s"), $rsrc, $!));
 290     }
 291
 292     if (open (TMP, ">>", "${rdest}.dpkg-devert.tmp")) {
 293         close TMP;
 294         unlink ("${rdest}.dpkg-devert.tmp");
 295     } else {
 296         quit(sprintf(_g("error checking \`%s': %s"), $rdest, $!));
 297     }
 298     if (@ssrc && @sdest &&
 299         !($ssrc[0] == $sdest[0] && $ssrc[1] == $sdest[1])) {
 300         quit(sprintf(_g("rename involves overwriting \`%s' with\n".
 301                         "  different file \`%s', not allowed"), $rdest, $rsrc));
 302     }
 303 }
 304
 305 sub rename_mv($$)
 306 {
 307     return (rename($_[0], $_[1]) || (system(("mv", $_[0], $_[1])) == 0));
 308 }
 309
 310 sub dorename {
 311     return unless $dorename;
 312     return if $testmode;
 313     if (@ssrc) {
 314         if (@sdest) {
 315             unlink($rsrc) || quit(sprintf(_g("rename: remove duplicate old link \`%s': %s"), $rsrc, $!));
 316         } else {
 317             rename_mv($rsrc, $rdest) ||
 318                 quit(sprintf(_g("rename: rename \`%s' to \`%s': %s"), $rsrc, $rdest, $!));
 319         }
 320     }
 321 }
 322
 323 sub save {
 324     return if $testmode;
 325     open(N, "> $admindir/diversions-new") || quit(sprintf(_g("create diversions-new: %s"), $!));
 326     chmod 0644, "$admindir/diversions-new";
 327     for (my $i = 0; $i <= $#contest; $i++) {
 328         print(N "$contest[$i]\n$altname[$i]\n$package[$i]\n")
 329             || quit(sprintf(_g("write diversions-new: %s"), $!));
 330     }
 331     close(N) || quit(sprintf(_g("close diversions-new: %s"), $!));
 332     unlink("$admindir/diversions-old") ||
 333         $! == ENOENT || quit(sprintf(_g("remove old diversions-old: %s"), $!));
 334     link("$admindir/diversions","$admindir/diversions-old") ||
 335         $! == ENOENT || quit(sprintf(_g("create new diversions-old: %s"), $!));
 336     rename("$admindir/diversions-new","$admindir/diversions")
 337         || quit(sprintf(_g("install new diversions: %s"), $!));
 338 }
 339
 340 sub infoa
 341 {
 342     infol($file, $divertto, $package);
 343 }
 344
 345 sub infon
 346 {
 347     my $i = shift;
 348     infol($contest[$i], $altname[$i], $package[$i]);
 349 }
 350
 351 sub quit
 352 {
 353     printf STDERR "%s: %s\n", $progname, "@_";
 354     exit(2);
 355 }
 356
 357 sub badusage
 358 {
 359     printf STDERR "%s: %s\n\n", $progname, "@_";
 360     usage();
 361     exit(2);
 362 }
 363
 364 sub badfmt
 365 {
 366     quit(sprintf(_g("internal error: %s corrupt: %s"), "$admindir/diversions", $_[0]));
 367 }
 368