scripts/dpkg-divert.pl

   1 #!/usr/bin/perl --
   2
   3 #use POSIX; &ENOENT;
   4 sub ENOENT { 2; }
   5 # Sorry about this, but POSIX.pm isn't necessarily available
   6
   7 $version= '1.0.11'; # This line modified by Makefile
   8 sub usageversion {
   9     print(STDERR <<END)
  10 Debian GNU/Linux dpkg-divert $version.  Copyright (C) 1995
  11 Ian Jackson.  This is free software; see the GNU General Public Licence
  12 version 2 or later for copying conditions.  There is NO warranty.
  13
  14 Usage:
  15  dpkg-divert [options] [--add] <file>
  16  dpkg-divert [options] --remove <file>
  17  dpkg-divert [options] --list [<glob-pattern>]
  18
  19 Options:  --package <package> | --local  --divert <divert-to>  --rename
  20           --quiet  --test  --help|--version  --admindir <directory>
  21
  22 <package> is the name of a package whose copy of <file> will not be diverted.
  23 <divert-to> is the name used by other packages' versions.
  24 --local specifies that all packages' versions are diverted.
  25 --rename causes dpkg-divert to actually move the file aside (or back).
  26
  27 When adding, default is --local and --divert <original>.distrib.
  28 When removing, --package or --local and --divert must match if specified.
  29 Package preinst/postrm scripts should always specify --package and --divert.
  30 END
  31         || &quit("failed to write usage: $!");
  32 }
  33
  34 $admindir= '/var/lib/dpkg';
  35 $testmode= 0;
  36 $dorename= 0;
  37 $verbose= 1;
  38 $mode='';
  39 $|=1;
  40
  41 sub checkmanymodes {
  42     return unless $mode;
  43     &badusage("two modes specified: $_ and --$mode");
  44 }
  45
  46 while (@ARGV) {
  47     $_= shift(@ARGV);
  48     last if m/^--$/;
  49     if (!m/^-/) {
  50         unshift(@ARGV,$_); last;
  51     } elsif (m/^--(help|version)$/) {
  52         &usageversion; exit(0);
  53     } elsif (m/^--test$/) {
  54         $testmode= 1;
  55     } elsif (m/^--rename$/) {
  56         $dorename= 1;
  57     } elsif (m/^--quiet$/) {
  58         $verbose= 0;
  59     } elsif (m/^--local$/) {
  60         $package= ':';
  61     } elsif (m/^--add$/) {
  62         &checkmanymodes;
  63         $mode= 'add';
  64     } elsif (m/^--remove$/) {
  65         &checkmanymodes;
  66         $mode= 'remove';
  67     } elsif (m/^--list$/) {
  68         &checkmanymodes;
  69         $mode= 'list';
  70     } elsif (m/^--divert$/) {
  71         @ARGV || &badusage("--divert needs a divert-to argument");
  72         $divertto= shift(@ARGV);
  73         $divertto =~ m/\n/ && &badusage("divert-to may not contain newlines");
  74     } elsif (m/^--package$/) {
  75         @ARGV || &badusage("--package needs a package argument");
  76         $package= shift(@ARGV);
  77         $divertto =~ m/\n/ && &badusage("package may not contain newlines");
  78     } elsif (m/^--admindir$/) {
  79         @ARGV || &badusage("--admindir needs a directory argument");
  80         $admindir= shift(@ARGV);
  81     } else {
  82         &badusage("unknown option \`$_'");
  83     }
  84 }
  85
  86 $mode='add' unless $mode;
  87
  88 open(O,"$admindir/diversions") || &quit("cannot open diversions: $!");
  89 while(<O>) {
  90     s/\n$//; push(@contest,$_);
  91     $_=<O>; s/\n$// || &badfmt("missing altname");
  92     push(@altname,$_);
  93     $_=<O>; s/\n$// || &badfmt("missing package");
  94     push(@package,$_);
  95 }
  96 close(O);
  97
  98 if ($mode eq 'add') {
  99     @ARGV == 1 || &badusage("--add needs a single argument");
 100     $file= $ARGV[0];
 101     $file =~ m/\n/ && &badusage("file may not contain newlines");
 102     $divertto= "$file.distrib" unless defined($divertto);
 103     $package= ':' unless defined($package);
 104     for ($i=0; $i<=$#contest; $i++) {
 105         if ($contest[$i] eq $file || $altname[$i] eq $file ||
 106             $contest[$i] eq $divertto || $altname[$i] eq $divertto) {
 107             if ($contest[$i] eq $file && $altname[$i] eq $divertto &&
 108                 $package[$i] eq $package) {
 109                 print "Leaving \`",&infon($i),"'\n" if $verbose > 0;
 110                 exit(0);
 111             }
 112             &quit("\`".&infoa."' clashes with \`".&infon($i)."'");
 113         }
 114     }
 115     push(@contest,$file);
 116     push(@altname,$divertto);
 117     push(@package,$package);
 118     print "Adding \`",&infon($#contest),"'\n" if $verbose > 0;
 119     &checkrename($file,$divertto);
 120     &save;
 121     &dorename($file,$divertto);
 122     exit(0);
 123 } elsif ($mode eq 'remove') {
 124     @ARGV == 1 || &badusage("--remove needs a single argument");
 125     $file= $ARGV[0];
 126     for ($i=0; $i<=$#contest; $i++) {
 127         next unless $file eq $contest[$i];
 128         &quit("mismatch on divert-to\n  when removing \`".&infoa."'\n  found \`".
 129               &infon($i)."'") if defined($divertto) && $altname[$i] ne $divertto;
 130         &quit("mismatch on package\n  when removing \`".&infoa."'\n  found \`".
 131               &infon($i)."'") if defined($package) && $package[$i] ne $package;
 132         print "Removing \`",&infon($i),"'\n" if $verbose > 0;
 133         $orgfile= $contest[$i];
 134         $orgdivertto= $altname[$i];
 135         @contest= (($i > 0 ? @contest[0..$i-1] : ()),
 136                    ($i < $#contest ? @contest[$i+1..$#contest] : ()));
 137         @altname= (($i > 0 ? @altname[0..$i-1] : ()),
 138                    ($i < $#altname ? @altname[$i+1..$#altname] : ()));
 139         @package= (($i > 0 ? @package[0..$i-1] : ()),
 140                    ($i < $#package ? @package[$i+1..$#package] : ()));
 141         &checkrename($orgdivertto,$orgfile);
 142         &dorename($orgdivertto,$orgfile);
 143         &save;
 144         exit(0);
 145     }
 146     print "No diversion \`",&infoa,"', none removed\n" if $verbose > 0;
 147     exit(0);
 148 } elsif ($mode eq 'list') {
 149     @ilist= @ARGV ? @ARGV : ('*');
 150     while (defined($_=shift(@ilist))) {
 151         s/\W/\\$&/g;
 152         s/\\\?/./g;
 153         s/\\\*/.*/g;
 154         push(@list,"^$_\$");
 155     }
 156     $pat= join('$|^',@list);
 157     for ($i=0; $i<=$#contest; $i++) {
 158         next unless ($contest[$i] =~ m/$pat/o ||
 159                      $altname[$i] =~ m/$pat/o ||
 160                      $package[$i] =~ m/$pat/o);
 161         print &infon($i),"\n";
 162     }
 163     exit(0);
 164 } else {
 165     &quit("internal error - bad mode \`$mode'");
 166 }
 167
 168 sub infol {
 169     return (($_[2] eq ':' ? "<local>" : length($_[2]) ? "$_[2]" : "<any>").
 170             ": $_[0]".
 171             (length($_[1]) ? " -> $_[1]" : ""));
 172 }
 173
 174 sub checkrename {
 175     return unless $dorename;
 176     ($rsrc,$rdest) = @_;
 177     (@ssrc= lstat($rsrc)) || $! == &ENOENT ||
 178         &quit("cannot stat old name \`$rsrc': $!");
 179     (@sdest= lstat($rdest)) || $! == &ENOENT ||
 180         &quit("cannot stat new name \`$rdest': $!");
 181     if (@ssrc && @sdest &&
 182         !($ssrc[0] == $sdest[0] && $ssrc[1] == $sdest[1])) {
 183         &quit("rename involves overwriting \`$rdest' with\n".
 184               "  different file \`$rsrc', not allowed");
 185     }
 186 }
 187
 188 sub dorename {
 189     return unless $dorename;
 190     if (@ssrc) {
 191         if (@sdest) {
 192             unlink($rsrc) || &quit("rename: remove duplicate old link \`$rsrc': $!");
 193         } else {
 194             rename($rsrc,$rdest) || &quit("rename: rename \`$rsrc' to \`$rdest': $!");
 195         }
 196     }
 197 }
 198
 199 sub save {
 200     return if $testmode;
 201     open(N,"> $admindir/diversions-new") || &quit("create diversions-new: $!");
 202     for ($i=0; $i<=$#contest; $i++) {
 203         print(N "$contest[$i]\n$altname[$i]\n$package[$i]\n")
 204             || &quit("write diversions-new: $!");
 205     }
 206     close(N) || &quit("close diversions-new: $!");
 207     unlink("$admindir/diversions-old") ||
 208         $! == &ENOENT || &quit("remove old diversions-old: $!");
 209     link("$admindir/diversions","$admindir/diversions-old") ||
 210         $! == &ENOENT || &quit("create new diversions-old: $!");
 211     rename("$admindir/diversions-new","$admindir/diversions")
 212         || &quit("install new diversions: $!");
 213 }
 214
 215 sub infoa { &infol($file,$divertto,$package); }
 216 sub infon { &infol($contest[$i],$altname[$i],$package[$i]); }
 217
 218 sub quit { print STDERR "dpkg-divert: @_\n"; exit(2); }
 219 sub badusage { print STDERR "dpkg-divert: @_\n\n"; &usageversion; exit(2); }
 220 sub badfmt { &quit("internal error: $admindir/diversions corrupt: $_[0]"); }