scripts/lib.pl

   1 # -*- perl -*-
   2 #
   3 # dpkg library: Debian GNU/Linux package maintenance utility,
   4 #  useful library functions.
   5 #
   6 # Copyright (C) 1994 Matt Welsh <mdw@sunsite.unc.edu>
   7 # Copyright (C) 1994 Carl Streeter <streeter@cae.wisc.edu>
   8 # Copyright (C) 1994 Ian Murdock <imurdock@debian.org>
   9 # Copyright (C) 1994 Ian Jackson <iwj10@cus.cam.ac.uk>
  10 #
  11 #   dpkg is free software; you can redistribute it and/or modify
  12 #   it under the terms of the GNU General Public License as
  13 #   published by the Free Software Foundation; either version 2,
  14 #   or (at your option) any later version.
  15 #
  16 #   dpkg is distributed in the hope that it will be useful, but
  17 #   WITHOUT ANY WARRANTY; without even the implied warranty of
  18 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 #   GNU General Public License for more details.
  20 #
  21 #   You should have received a copy of the GNU General Public
  22 #   License along with dpkg; if not, write to the Free Software
  23 #   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 #   /var/lib/dpkg/ +---- status
  26 #                  |---- updates/ +---- <id>
  27 #                  |              |---- tmp.i
  28 #                  |              \---- <id>.new
  29 #                  |---- available
  30 #                  |---- lock
  31 #                  |---- info/ |---- <package>.{post,pre}{inst,rm}
  32 #                  |---- tmp.$$
  33 #                  \---- tmp.ci/ +---- control
  34 #                                |---- conffiles
  35 #                                |---- {post,pre}{inst,rm}
  36 #                                |---- list
  37 #                                \---- conffiles
  38
  39 $backend = "dpkg-deb";
  40 $fpextract = "dpkg-deb";
  41 $md5sum = "md5sum";
  42 $dselect = "dselect";
  43 $dpkg = "dpkg";
  44
  45 $status_mergeevery = 20;
  46 $tmp = "/tmp";
  47 $visiblecontroldir = "DEBIAN";
  48
  49 sub setadmindir {
  50     $dd = $_[0];
  51     $statusdb    = "$dd/status";
  52     $updatesdir  = "$dd/updates";
  53     $availabledb = "$dd/available";
  54     $scriptsdir  = "$dd/info";
  55     $listsdir    = "$dd/info";
  56     $lockfile    = "$dd/lock";
  57     $lockmine    = "$dd/tmp.$$";
  58     $controli    = "$dd/tmp.ci";
  59     $importantspace = "$updatesdir/tmp.i";
  60 }
  61 $orgadmindir= "/var/lib/dpkg";
  62 &setadmindir($orgadmindir);
  63
  64 @nokeepfields= ('package','version','package_revision',
  65                 'depends','recommended','optional','conflicts','part');
  66 # Don't keep these fields in the Available database if a new record is
  67 # merged which is missing values for any of them.
  68
  69 $packagere = '\w[-_a-zA-Z0-9+.@:=%]+';
  70 $packageversionre= $packagere.'(\s*\([^()]+\))?';
  71 $singledependencyre= "$packageversionre(\\s*\\|\\s*$packageversionre)*";
  72
  73 # Abbreviations for dpkg-deb options common to dpkg & dpkg-deb.
  74 %debabbrevact= ('b','build', 'c','contents', 'e','control', 'i','info',
  75                 'f','field', 'x','extract', 'X','vextract');
  76
  77 @keysortorder= ('package', 'status', 'version', 'package_revision',
  78                 'maintainer', 'description',
  79                 'depends', 'recommended', 'optional', 'conflicts',
  80                 'list', 'conffiles');
  81
  82 #*** replacements for things in headers ***#
  83
  84 #require 'sys/errno.ph';
  85 sub ENOENT              { 2; }          # No such file or directory
  86 sub EEXIST              { 17; }         # File exists
  87 sub EISDIR              { 21; }         # Is a directory
  88 sub ENOTEMPTY           { 39; }         # Directory not empty
  89
  90 #require 'sys/stat.ph';
  91 sub S_IFMT      { 00170000; }
  92 sub S_IFREG     { 0100000; }
  93 sub S_IFLNK     { 0120000; }
  94 sub S_ISREG     { ($_[0] & &S_IFMT) == &S_IFREG; }
  95 sub S_ISLNK     { ($_[0] & &S_IFMT) == &S_IFLNK; }
  96
  97 #require 'sys/wait.ph';
  98 sub WIFEXITED { ($_[0] & 0x0ff) == 0; }
  99 sub WIFSTOPPED { ($_[0] & 0x0ff) == 0x07f; }
 100 sub WIFSIGNALED { !&WIFEXITED && !&WIFSTOPPED; }
 101 sub WCOREDUMP { ($_[0] & 0x080) != 0; }
 102 sub WEXITSTATUS { ($_[0] & 0x0ff00) >> 8; }
 103 sub WSTOPSIG { ($_[0] & 0x0ff00) >> 8; }
 104 sub WTERMSIG { $_[0] & 0x07f; }
 105
 106 #require 'sys/signal.ph';
 107 sub SIGPIPE             { 13; }
 108
 109 #require 'sys/syscall.ph';
 110 sub SYS_lseek           { 19; }
 111
 112
 113 #*** /var/lib/dpkg database management - `exported' routines ***#
 114
 115 sub database_start {
 116     # Lock the package management databases, amalgamate any
 117     # changes files, and leave the results in:
 118     #  From /var/lib/dpkg/status:
 119     #   %st_pk2v{ package_name, field_name } = field_value
 120     #   %st_p21{ package_name } = 1
 121     #  From /var/lib/dpkg/available:
 122     #   %av_pk2v{ package_name, field_name } = field_value
 123     #   %av_p21{ package_name } = 1
 124     #  From both:
 125     #   %all_k21{ field_name } = 1
 126     &lock_database;
 127     &read_status_mainfile;
 128     &read_status_extrafiles;
 129     &write_status_mainfile;
 130     &delete_status_extrafiles;
 131     &read_available_file;
 132     &prepare_important_database;
 133     &invent_status_availableonly_packages;
 134 }
 135
 136 sub database_finish {
 137     # Tidy up and unlock the package management databases.
 138     &release_important_database;
 139     &write_available_file;
 140     &write_status_mainfile;
 141     &delete_status_extrafiles;
 142     &unlock_database;
 143 }
 144
 145 sub amended_status {
 146     # Record amended status of package (in an `extra' file).
 147     local (@packages) = @_;
 148     local ($p);
 149     &debug("amended @packages");
 150     for $p (@packages) {
 151         $st_pk2v{$p,'status'}= "$st_p2w{$p} $st_p2h{$p} $st_p2s{$p}";
 152         $st_p21{$p}= 1;
 153     }
 154     $all_k21{'status'}= 1;
 155     local ($ef) = sprintf("%03d",$next_extrafile++);
 156     &write_database_file("$updatesdir/$ef",*st_pk2v,*st_p21,1,@packages);
 157     push(@status_extrafiles_done,$ef); &sync;
 158     if ($next_extrafile >= $status_mergeevery) {
 159         &write_status_mainfile;
 160         &delete_status_extrafiles;
 161     }
 162     $status_modified= 1;
 163     for $p (@packages) { delete $st_pk2v{$p,'status'}; }
 164     &prepare_important_database;
 165 }
 166
 167 sub note_amended_status {
 168     # Note the fact that the status has been modified, but don't
 169     # commit yet.
 170     $status_modified= 1;
 171 }
 172
 173 sub amended_available {
 174     # Record amended available information (in core for the moment -
 175     # noncritical, so we defer writing it out).
 176     $available_modified++;
 177     &invent_status_availableonly_packages(@_);
 178 }
 179
 180 #*** internal routines ***#
 181
 182 sub invent_status_availableonly_packages {
 183     local ($p);
 184     for $p (@_ ? @_ : keys %av_p21) {
 185         next if defined($st_p2w{$p});
 186         $st_p2w{$p}= 'unknown';
 187         $st_p2h{$p}= 'ok';
 188         $st_p2s{$p}= 'not-installed';
 189     }
 190 }
 191
 192 sub read_status_mainfile {
 193     local ($p, @p);
 194     &read_status_database_file($statusdb);
 195 }
 196
 197 sub read_status_extrafiles {
 198     local ($fn);
 199     opendir(UPD,$updatesdir) || &bombout("cannot opendir updates $updatesdir: $!");
 200     for $_ (sort readdir(UPD)) {
 201         next if $_ eq '.' || $_ eq '..';
 202         if (m/\.new$/ || m/\.old$/ || $_ eq 'tmp.i') {
 203             unlink("$updatesdir/$_") ||
 204                 &bombout("cannot unlink old update temp file $updatesdir/$_: $!");
 205         } elsif (m/^\d+$/) {
 206             $fn= $_;
 207             &read_status_database_file("$updatesdir/$fn");
 208             $status_modified= 1;  push(@status_extrafiles_done, $fn);
 209         } else {
 210             warn("$name: ignoring unexpected file in $updatesdir named \`$_'\n");
 211         }
 212     }
 213     closedir(UPD);
 214 }
 215
 216 sub read_status_database_file {
 217     local ($filename) = @_;
 218     @p= &read_database_file($filename,*st_pk2v,*st_p21);
 219     for $p (@p) {
 220         if (defined($st_pk2v{$p,'status'})) {
 221             $v= $st_pk2v{$p,'status'};
 222             $v =~ y/A-Z/a-z/;
 223             $v =~
 224                 m/^(unknown|install|deinstall|purge)\s+(ok|hold)\s+(not-installed|unpacked|postinst-failed|installed|removal-failed|config-files)$/
 225                     || &bombout("package \`$p' has bad status in $statusdb (\`$v')");
 226             $st_p2w{$p}= $1;
 227             $st_p2h{$p}= $2;
 228             $st_p2s{$p}= $3;
 229         }
 230         delete($st_pk2v{$p,'status'});
 231     }
 232     $status_modified= 0; @status_extrafiles_done= ();
 233 }
 234
 235 sub write_status_mainfile {
 236     return unless $status_modified;
 237     local ($p);
 238     for $p (keys %st_p21) {
 239         $st_pk2v{$p,'status'}= "$st_p2w{$p} $st_p2h{$p} $st_p2s{$p}";
 240     }
 241     $all_k21{'status'}= 1;
 242     unlink("$statusdb.old") || $!==&ENOENT ||
 243         &bombout("unable to remove $statusdb.old: $!");
 244     link("$statusdb","$statusdb.old") ||
 245         &bombout("unable to back up $statusdb: $!");
 246     &write_database_file($statusdb,*st_pk2v,*st_p21,0);
 247     $status_modified= 0;
 248     &sync;
 249     for $p (keys %st_p21) { delete $st_pk2v{$p,'status'}; }
 250 }
 251
 252 sub delete_status_extrafiles {
 253 #print STDERR "delete @status_extrafiles_done> "; <STDIN>;
 254     for $_ (@status_extrafiles_done) {
 255         unlink("$updatesdir/$_") ||
 256             &bombout("cannot remove already-done update file $updatesdir/$_: $!");
 257     }
 258     $next_extrafile= 0;
 259     @status_extrafiles_done= ();
 260 }
 261
 262 sub read_available_file {
 263     &read_database_file($availabledb,*av_pk2v,*av_p21);
 264     $available_modified= 0;
 265 }
 266
 267 sub write_available_file {
 268     return unless $available_modified;
 269     &write_database_file($availabledb,*av_pk2v,*av_p21,0);
 270     $available_modified= 0;
 271 }
 272
 273 #*** bottom level of read routines ***#
 274
 275 sub read_database_file {
 276     local ($filename, *xx_pk2v, *xx_p21) = @_;
 277     local ($quick,$cf,@cf,%cf_k2v,@cwarnings,@cerrors,$p,@p)= 1;
 278     &debug("reading database file $filename");
 279     open(DB,"<$filename") || &bombout("unable to open $filename for reading: $!");
 280     $/="";
 281     @p=();
 282     while (defined($cf=<DB>)) {
 283         chop($cf);
 284 #       $cf =~ s/\n+$/\n/;
 285         $p= &parse_control_entry;
 286 #        if (@cwarnings) {
 287 #            warn("$name: warning, packaging database file $filename\n".
 288 #                 " contains oddities in entry for package \`$p':\n  ".
 289 #                 join(";\n  ",@cwarnings).
 290 #                 ".\n This is probably a symptom of a bug.\n");
 291 #        }
 292         if (@cerrors) {
 293             &bombout("packaging database corruption - please report:\n".
 294                      " file $filename has error(s) in entry for \`$p':\n  ".
 295                      join(";\n  ",@cerrors). ".");
 296         }
 297         $xx_p21{$p}= 1;
 298         for $k (keys %all_k21) { $xx_pk2v{$p,$k}= $cf_k2v{$k}; }
 299         push(@p,$p);
 300     }
 301     &debug("database file $filename read");
 302     $/="\n"; close(DB);
 303     return @p;
 304 }
 305
 306 sub parse_control_entry {
 307     # Expects $cf to be a sequence of lines,
 308     # representing exactly one package's information.
 309     # Results are put in cf_k2v.
 310     # @warnings and @errors are made to contain warning and error
 311     # messages, respectively.
 312     local ($ln,$k,$v,$p,$l);
 313     @cwarnings= @cerrors= ();
 314
 315     undef %cf_k2v;
 316 #   &debug(">>>$cf<<<#\n");
 317     if (!$quick) {
 318         if ($cf =~ s/\n\n+/\n/g) { push(@cwarnings, "blank line(s) found and ignored"); }
 319         if ($cf =~ s/^\n+//) { push(@cwarnings, "blank line(s) at start ignored"); }
 320         if ($cf !~ m/\n$/) {
 321             $cf.= "\n"; push(@cwarnings, "missing newline after last line assumed");
 322         }
 323         if ($cf =~ s/\0//g) {
 324             push(@cwarnings, "nul characters discarded");
 325         }
 326     }
 327     $cf =~ s/\n([ \t])/\0$1/g; # join lines
 328 #   &debug(">>>$cf<<<*\n");
 329     $ln = 0;
 330     for $_ (split(/\n/,$cf)) {
 331         $ln++; s/\s+$//;
 332         next if m/^#/;
 333         m/^(\S+):[ \t]*/ || (push(@cerrors, "garbage at line $ln, \`$_'"), next);
 334         $k= $1; $v= $'; $k =~ y/A-Z/a-z/; $k='package_revision' if $k eq 'revision';
 335 #       &debug("key=\`$k' value=\`$v' line=\`$_'\n");
 336         $ln += ($v =~ s/\0/\n/g);
 337         $cf_k2v{$k}= $v;
 338         $all_k21{$k}= 1;
 339 #     while ($cf =~ s/^(\S+):[ \t]*(.*)\n//) {
 340     }
 341     return unless keys %cf_k2v;
 342     $p= $cf_k2v{'package'}; delete $cf_k2v{'package'}; delete $all_k21{'package'};
 343     $cf_k2v{'class'} =~ y/A-Z/a-z/ if defined($cf_k2v{'class'});
 344     $cf_k2v{'section'} =~ y/A-Z/a-z/ if defined($cf_k2v{'section'});
 345 #    length($cf) &&
 346 #        push(@cerrors, "garbage at line $ln, \`".($cf =~ m/\n/ ? $` : $cf)."'");
 347     if (!$quick) {
 348         defined($p) || push(@cerrors, "no \`package' line");
 349         $p =~ m/^$packagere$/o || &bad_control_field('package');
 350         defined($cf_k2v{'version'}) || push(@cerrors, "no Version field");
 351         for $f ('depends','recommended','optional','conflicts') {
 352             next unless defined($cf_k2v{$f}) && length($cf_k2v{$f});
 353             $cf_k2v{$f} =~ m/^$singledependencyre(\s*,\s*$singledependencyre)*$/o
 354                 || &bad_control_field("$f");
 355         }
 356     }
 357     return $p;
 358 }
 359
 360 sub bad_control_field {
 361     push(@cerrors, "bad \`$_[0]' line, contains \`$cf_k2v{$_[0]}'");
 362 }
 363
 364 #*** bottom level of database writing code ***#
 365
 366 sub write_database_file {
 367     local ($filename, *xx_pk2v, *xx_p21, $important, @packages) = @_;
 368     local ($p,$tl,$k,$v);
 369     if (!@packages) { @packages= keys(%xx_p21); }
 370
 371     &debug("called write_database_file $filename, important=$important, for @packages");
 372     if (!$important) {
 373         open(DB,">$filename.new") || &bombout("unable to create $filename.new: $!");
 374     }
 375     $tl= 0;
 376     for $p (@packages) {
 377         &write_database_string("\n") if $tl;
 378         &write_database_string("Package: $p\n");
 379         for $k (keys %all_k21) {
 380             next unless defined($xx_pk2v{$p,$k});
 381             $v= $xx_pk2v{$p,$k};
 382             $v =~ s/\n(\S)/\n $1/g;
 383             &write_database_string("$k: $v\n");
 384         }
 385     }
 386     if ($important) {
 387         if (!truncate(IMP,$tl)) {
 388             if (print(IMP "#")) {
 389                 warn("$name: warning - unable to truncate $importantspace: $!;".
 390                      "\n commenting the rest out instead seems to have worked.\n");
 391             } else {
 392                 &database_corrupted("unable to truncate $importantspace: $!");
 393             }
 394         }
 395         close(IMP) || &database_corrupted("unable to close $importantspace: $!");
 396         rename($importantspace,$filename) ||
 397             &database_corrupted("unable to install $importantspace as $filename: $!");
 398     } else {
 399         close(DB) || &bombout("unable to close $filename.new: $!");
 400         rename("$filename.new",$filename) ||
 401             &bombout("unable to install $filename.new as $filename: $!");
 402     }
 403 }
 404
 405 sub write_database_string {
 406     $tl += length($_[0]);
 407     if ($important) {
 408         print(IMP $_[0]) ||
 409             &database_corrupted("failed write to update file $importantspace: $!");
 410     } else {
 411         print(DB $_[0]) ||
 412             &bombout("failed to write to $filename.new: $!");
 413     }
 414 }
 415
 416 sub database_corrupted {
 417     &debug("corruptingstatus @_");
 418     print STDERR "$name - really horrible error:\n @_\n".
 419         "Package manager status data is now out of step with installed system.\n".
 420         "(Last action has not been recorded.  Please try re-installing \`@packages'\n".
 421         "to ensure system consistency, or seek assistance from an expert if\n".
 422         "problems persist.)\n";
 423     &cleanup; exit(2);
 424 }
 425
 426 sub prepare_important_database {
 427     open(IMP,"+>$importantspace") || &bombout("unable to create $importantspace: $!");
 428     select((select(IMP),$|=1)[0]);
 429     print(IMP "#padding\n"x512) || &bombout("unable to pad $importantspace: $!");
 430     seek(IMP,0,0) || &bombout("unable to seek (rewind) $importantspace: $!");
 431     &debug("important database prepared");
 432 }
 433
 434 sub release_important_database {
 435     close(IMP);
 436     unlink($importantspace) || &bombout("unable to delete $importantspace: $!");
 437     &debug("important database released");
 438 }
 439
 440 #*** database lock management ***#
 441
 442 sub lock_database {
 443     # Lock the package management databases.  Stale locks will
 444     # be broken, but there is no concurrency checking on the lock-
 445     # breaking code.
 446     push(@cleanups,'unlink($lockmine)');
 447     open(PID,">$lockmine") || &bombout("failed to create new pid file $lockmine: $!");
 448     printf(PID "%010d\n",$$) || &bombout("failed to add pid to $lockmine: $!");
 449     close(PID) || &bombout("failed to close new pid file $lockmine: $!");
 450     unless (link($lockmine,$lockfile)) {
 451         $! == &EEXIST || &bombout("failed to create lock on packages database: $!");
 452         if (open(PID,"<$lockfile")) {
 453             undef $/; $opid= <PID>; $/="\n";
 454             $opid =~ m/^\d{10}\n$/ || &lockfailed(" (pid missing)");
 455             close(PID);
 456             -d '/proc/self' ||
 457                 &bombout("/proc/self not found ($!) - /proc not mounted ?");
 458             -d sprintf("/proc/%d",$opid) && &lockfailed(" (in use by pid $opid)");
 459             if (open(PID,"<$lockfile")) {
 460                 $opid eq <PID> || &lockfailed(' (pid changed)');
 461                 close(PID);
 462                 unlink($lockfile) ||
 463                     &bombout("failed to break stale lock on database: $!");
 464                 print STDERR
 465                     "$name: stale lock found on packages database, lock forced\n";
 466             } else {
 467                 $!==&ENOENT ||
 468                     &bombout("failed to confirm who owns lock on database: $!");
 469             }
 470         } else {
 471             $!==&ENOENT || &bombout("failed to determine who owns lock on database: $!");
 472         }
 473         link($lockmine,$lockfile) ||
 474             &bombout("failed to create lock on packages database: $!");
 475     }
 476     push(@cleanups, 'unlink($lockfile) ||
 477                      warn("$name: failed to unlock packages database: $!\n")');
 478     unlink($lockmine);
 479 }
 480
 481 sub unlock_database {
 482     unlink($lockfile) || &bombout("failed to unlock packages database: $!");
 483     pop(@cleanups);
 484 }
 485
 486 #*** error handling ***#
 487
 488 sub lockfailed  { &bombout("unable to lock packages database@_"); }
 489 sub bombout     { print STDERR "$name - critical error: @_\n"; &cleanup; exit(2); }
 490 sub badusage    { print STDERR "$name: @_\n\n"; &usage; &cleanup; exit(3); }
 491
 492 sub outerr {
 493     &bombout("failed write to stdout: $!");
 494 }
 495
 496 sub cleanup {
 497     while (@cleanups) {
 498         eval(pop(@cleanups));
 499         $@ && print STDERR "error while cleaning up: $@";
 500     }
 501 }
 502
 503 sub debug {
 504     return unless $debug;
 505     print "D: @_\n";
 506 }
 507
 508 sub ecode {
 509     local ($w,$s) = ($?,$!);
 510     &debug("ecode $w syserr $s");
 511     return
 512 #       (($w & 0x0ffff) == 0x0ff00 ? "problems running program - exit code -1" :
 513 #        ($w & 0x0ff) == 0 ? "exit status ".(($w & 0x0ff00) >> 8) :
 514 #        ($w & 0x0ff) == 0x07f ? "stopped by signal ".(($w & 0x0ff00) >> 8) :
 515 #        "killed by signal ".($w & 0x07f).($w & 0x080 ? " (core dumped)" : '')).
 516         (&WIFEXITED($w) ? "exit status ".&WEXITSTATUS($w) :
 517          &WIFSIGNALED($w) ? "killed by signal ".&WTERMSIG($w).
 518          (&WCOREDUMP($w) ? " (core dumped)" : ""):
 519          &WIFSTOPPED($w) ? "stopped due to signal ".&WSTOPSIG($w) :
 520          "unknown status $w").
 521         ($s ? ", system error $s" : '');
 522 }
 523
 524 #*** miscellaneous helpful routines ***#
 525
 526 sub readall {
 527     local ($fh) = @_;
 528     local ($r,$n,$this) = '';
 529     for (;;) {
 530         defined($n=read($fh,$this,4096)) || return undef;
 531         $n || last;
 532         $r.= $this;
 533     }
 534     return $r;
 535 }
 536
 537 #sub debug_compare_verrevs {
 538 #    local (@i)= @_;
 539 #    local ($i)= &x_compare_verrevs(@i);
 540 #    &debug("compare_verrevs >@i< = >$i<");
 541 #    return $i;
 542 #}
 543
 544 sub compare_verrevs {
 545     local ($av,$ar,$bv,$br,$c) = @_;
 546     $c = &compare_vnumbers($av,$bv);  return $c if $c;
 547     return &compare_vnumbers($ar,$br);
 548 }
 549
 550 sub compare_vnumbers {
 551     local ($a, $b) = @_;
 552     do {
 553         $a =~ s/^\D*//; $ad= $&; $ad =~ s/\W/ /g;
 554         $b =~ s/^\D*//; $bd= $&; $bd =~ s/\W/ /g;
 555         $cm = $ad cmp $bd; return $cm if $cm;
 556         $a =~ s/^\d*//; $ad= $&;
 557         $b =~ s/^\d*//; $bd= $&;
 558         $cm = $ad <=> $bd; return $cm if $cm;
 559     } while (length ($a) && length ($b));
 560     return length ($a) cmp length ($b);
 561 }
 562
 563 sub sync {
 564     system('sync');
 565 }