diff options
Diffstat (limited to 'scripts/lib.pl')
| -rw-r--r-- | scripts/lib.pl | 565 |
1 files changed, 565 insertions, 0 deletions
diff --git a/scripts/lib.pl b/scripts/lib.pl new file mode 100644 index 000000000..ba9c12765 --- /dev/null +++ b/scripts/lib.pl @@ -0,0 +1,565 @@ +# -*- perl -*- +# +# dpkg library: Debian GNU/Linux package maintenance utility, +# useful library functions. +# +# Copyright (C) 1994 Matt Welsh <mdw@sunsite.unc.edu> +# Copyright (C) 1994 Carl Streeter <streeter@cae.wisc.edu> +# Copyright (C) 1994 Ian Murdock <imurdock@debian.org> +# Copyright (C) 1994 Ian Jackson <iwj10@cus.cam.ac.uk> +# +# dpkg is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as +# published by the Free Software Foundation; either version 2, +# or (at your option) any later version. +# +# dpkg is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public +# License along with dpkg; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# /var/lib/dpkg/ +---- status +# |---- updates/ +---- <id> +# | |---- tmp.i +# | \---- <id>.new +# |---- available +# |---- lock +# |---- info/ |---- <package>.{post,pre}{inst,rm} +# |---- tmp.$$ +# \---- tmp.ci/ +---- control +# |---- conffiles +# |---- {post,pre}{inst,rm} +# |---- list +# \---- conffiles + +$backend = "dpkg-deb"; +$fpextract = "dpkg-deb"; +$md5sum = "md5sum"; +$dselect = "dselect"; +$dpkg = "dpkg"; + +$status_mergeevery = 20; +$tmp = "/tmp"; +$visiblecontroldir = "DEBIAN"; + +sub setadmindir { + $dd = $_[0]; + $statusdb = "$dd/status"; + $updatesdir = "$dd/updates"; + $availabledb = "$dd/available"; + $scriptsdir = "$dd/info"; + $listsdir = "$dd/info"; + $lockfile = "$dd/lock"; + $lockmine = "$dd/tmp.$$"; + $controli = "$dd/tmp.ci"; + $importantspace = "$updatesdir/tmp.i"; +} +$orgadmindir= "/var/lib/dpkg"; +&setadmindir($orgadmindir); + +@nokeepfields= ('package','version','package_revision', + 'depends','recommended','optional','conflicts','part'); +# Don't keep these fields in the Available database if a new record is +# merged which is missing values for any of them. + +$packagere = '\w[-_a-zA-Z0-9+.@:=%]+'; +$packageversionre= $packagere.'(\s*\([^()]+\))?'; +$singledependencyre= "$packageversionre(\\s*\\|\\s*$packageversionre)*"; + +# Abbreviations for dpkg-deb options common to dpkg & dpkg-deb. +%debabbrevact= ('b','build', 'c','contents', 'e','control', 'i','info', + 'f','field', 'x','extract', 'X','vextract'); + +@keysortorder= ('package', 'status', 'version', 'package_revision', + 'maintainer', 'description', + 'depends', 'recommended', 'optional', 'conflicts', + 'list', 'conffiles'); + +#*** replacements for things in headers ***# + +#require 'sys/errno.ph'; +sub ENOENT { 2; } # No such file or directory +sub EEXIST { 17; } # File exists +sub EISDIR { 21; } # Is a directory +sub ENOTEMPTY { 39; } # Directory not empty + +#require 'sys/stat.ph'; +sub S_IFMT { 00170000; } +sub S_IFREG { 0100000; } +sub S_IFLNK { 0120000; } +sub S_ISREG { ($_[0] & &S_IFMT) == &S_IFREG; } +sub S_ISLNK { ($_[0] & &S_IFMT) == &S_IFLNK; } + +#require 'sys/wait.ph'; +sub WIFEXITED { ($_[0] & 0x0ff) == 0; } +sub WIFSTOPPED { ($_[0] & 0x0ff) == 0x07f; } +sub WIFSIGNALED { !&WIFEXITED && !&WIFSTOPPED; } +sub WCOREDUMP { ($_[0] & 0x080) != 0; } +sub WEXITSTATUS { ($_[0] & 0x0ff00) >> 8; } +sub WSTOPSIG { ($_[0] & 0x0ff00) >> 8; } +sub WTERMSIG { $_[0] & 0x07f; } + +#require 'sys/signal.ph'; +sub SIGPIPE { 13; } + +#require 'sys/syscall.ph'; +sub SYS_lseek { 19; } + + +#*** /var/lib/dpkg database management - `exported' routines ***# + +sub database_start { + # Lock the package management databases, amalgamate any + # changes files, and leave the results in: + # From /var/lib/dpkg/status: + # %st_pk2v{ package_name, field_name } = field_value + # %st_p21{ package_name } = 1 + # From /var/lib/dpkg/available: + # %av_pk2v{ package_name, field_name } = field_value + # %av_p21{ package_name } = 1 + # From both: + # %all_k21{ field_name } = 1 + &lock_database; + &read_status_mainfile; + &read_status_extrafiles; + &write_status_mainfile; + &delete_status_extrafiles; + &read_available_file; + &prepare_important_database; + &invent_status_availableonly_packages; +} + +sub database_finish { + # Tidy up and unlock the package management databases. + &release_important_database; + &write_available_file; + &write_status_mainfile; + &delete_status_extrafiles; + &unlock_database; +} + +sub amended_status { + # Record amended status of package (in an `extra' file). + local (@packages) = @_; + local ($p); + &debug("amended @packages"); + for $p (@packages) { + $st_pk2v{$p,'status'}= "$st_p2w{$p} $st_p2h{$p} $st_p2s{$p}"; + $st_p21{$p}= 1; + } + $all_k21{'status'}= 1; + local ($ef) = sprintf("%03d",$next_extrafile++); + &write_database_file("$updatesdir/$ef",*st_pk2v,*st_p21,1,@packages); + push(@status_extrafiles_done,$ef); &sync; + if ($next_extrafile >= $status_mergeevery) { + &write_status_mainfile; + &delete_status_extrafiles; + } + $status_modified= 1; + for $p (@packages) { delete $st_pk2v{$p,'status'}; } + &prepare_important_database; +} + +sub note_amended_status { + # Note the fact that the status has been modified, but don't + # commit yet. + $status_modified= 1; +} + +sub amended_available { + # Record amended available information (in core for the moment - + # noncritical, so we defer writing it out). + $available_modified++; + &invent_status_availableonly_packages(@_); +} + +#*** internal routines ***# + +sub invent_status_availableonly_packages { + local ($p); + for $p (@_ ? @_ : keys %av_p21) { + next if defined($st_p2w{$p}); + $st_p2w{$p}= 'unknown'; + $st_p2h{$p}= 'ok'; + $st_p2s{$p}= 'not-installed'; + } +} + +sub read_status_mainfile { + local ($p, @p); + &read_status_database_file($statusdb); +} + +sub read_status_extrafiles { + local ($fn); + opendir(UPD,$updatesdir) || &bombout("cannot opendir updates $updatesdir: $!"); + for $_ (sort readdir(UPD)) { + next if $_ eq '.' || $_ eq '..'; + if (m/\.new$/ || m/\.old$/ || $_ eq 'tmp.i') { + unlink("$updatesdir/$_") || + &bombout("cannot unlink old update temp file $updatesdir/$_: $!"); + } elsif (m/^\d+$/) { + $fn= $_; + &read_status_database_file("$updatesdir/$fn"); + $status_modified= 1; push(@status_extrafiles_done, $fn); + } else { + warn("$name: ignoring unexpected file in $updatesdir named \`$_'\n"); + } + } + closedir(UPD); +} + +sub read_status_database_file { + local ($filename) = @_; + @p= &read_database_file($filename,*st_pk2v,*st_p21); + for $p (@p) { + if (defined($st_pk2v{$p,'status'})) { + $v= $st_pk2v{$p,'status'}; + $v =~ y/A-Z/a-z/; + $v =~ + m/^(unknown|install|deinstall|purge)\s+(ok|hold)\s+(not-installed|unpacked|postinst-failed|installed|removal-failed|config-files)$/ + || &bombout("package \`$p' has bad status in $statusdb (\`$v')"); + $st_p2w{$p}= $1; + $st_p2h{$p}= $2; + $st_p2s{$p}= $3; + } + delete($st_pk2v{$p,'status'}); + } + $status_modified= 0; @status_extrafiles_done= (); +} + +sub write_status_mainfile { + return unless $status_modified; + local ($p); + for $p (keys %st_p21) { + $st_pk2v{$p,'status'}= "$st_p2w{$p} $st_p2h{$p} $st_p2s{$p}"; + } + $all_k21{'status'}= 1; + unlink("$statusdb.old") || $!==&ENOENT || + &bombout("unable to remove $statusdb.old: $!"); + link("$statusdb","$statusdb.old") || + &bombout("unable to back up $statusdb: $!"); + &write_database_file($statusdb,*st_pk2v,*st_p21,0); + $status_modified= 0; + &sync; + for $p (keys %st_p21) { delete $st_pk2v{$p,'status'}; } +} + +sub delete_status_extrafiles { +#print STDERR "delete @status_extrafiles_done> "; <STDIN>; + for $_ (@status_extrafiles_done) { + unlink("$updatesdir/$_") || + &bombout("cannot remove already-done update file $updatesdir/$_: $!"); + } + $next_extrafile= 0; + @status_extrafiles_done= (); +} + +sub read_available_file { + &read_database_file($availabledb,*av_pk2v,*av_p21); + $available_modified= 0; +} + +sub write_available_file { + return unless $available_modified; + &write_database_file($availabledb,*av_pk2v,*av_p21,0); + $available_modified= 0; +} + +#*** bottom level of read routines ***# + +sub read_database_file { + local ($filename, *xx_pk2v, *xx_p21) = @_; + local ($quick,$cf,@cf,%cf_k2v,@cwarnings,@cerrors,$p,@p)= 1; + &debug("reading database file $filename"); + open(DB,"<$filename") || &bombout("unable to open $filename for reading: $!"); + $/=""; + @p=(); + while (defined($cf=<DB>)) { + chop($cf); +# $cf =~ s/\n+$/\n/; + $p= &parse_control_entry; +# if (@cwarnings) { +# warn("$name: warning, packaging database file $filename\n". +# " contains oddities in entry for package \`$p':\n ". +# join(";\n ",@cwarnings). +# ".\n This is probably a symptom of a bug.\n"); +# } + if (@cerrors) { + &bombout("packaging database corruption - please report:\n". + " file $filename has error(s) in entry for \`$p':\n ". + join(";\n ",@cerrors). "."); + } + $xx_p21{$p}= 1; + for $k (keys %all_k21) { $xx_pk2v{$p,$k}= $cf_k2v{$k}; } + push(@p,$p); + } + &debug("database file $filename read"); + $/="\n"; close(DB); + return @p; +} + +sub parse_control_entry { + # Expects $cf to be a sequence of lines, + # representing exactly one package's information. + # Results are put in cf_k2v. + # @warnings and @errors are made to contain warning and error + # messages, respectively. + local ($ln,$k,$v,$p,$l); + @cwarnings= @cerrors= (); + + undef %cf_k2v; +# &debug(">>>$cf<<<#\n"); + if (!$quick) { + if ($cf =~ s/\n\n+/\n/g) { push(@cwarnings, "blank line(s) found and ignored"); } + if ($cf =~ s/^\n+//) { push(@cwarnings, "blank line(s) at start ignored"); } + if ($cf !~ m/\n$/) { + $cf.= "\n"; push(@cwarnings, "missing newline after last line assumed"); + } + if ($cf =~ s/\0//g) { + push(@cwarnings, "nul characters discarded"); + } + } + $cf =~ s/\n([ \t])/\0$1/g; # join lines +# &debug(">>>$cf<<<*\n"); + $ln = 0; + for $_ (split(/\n/,$cf)) { + $ln++; s/\s+$//; + next if m/^#/; + m/^(\S+):[ \t]*/ || (push(@cerrors, "garbage at line $ln, \`$_'"), next); + $k= $1; $v= $'; $k =~ y/A-Z/a-z/; $k='package_revision' if $k eq 'revision'; +# &debug("key=\`$k' value=\`$v' line=\`$_'\n"); + $ln += ($v =~ s/\0/\n/g); + $cf_k2v{$k}= $v; + $all_k21{$k}= 1; +# while ($cf =~ s/^(\S+):[ \t]*(.*)\n//) { + } + return unless keys %cf_k2v; + $p= $cf_k2v{'package'}; delete $cf_k2v{'package'}; delete $all_k21{'package'}; + $cf_k2v{'class'} =~ y/A-Z/a-z/ if defined($cf_k2v{'class'}); + $cf_k2v{'section'} =~ y/A-Z/a-z/ if defined($cf_k2v{'section'}); +# length($cf) && +# push(@cerrors, "garbage at line $ln, \`".($cf =~ m/\n/ ? $` : $cf)."'"); + if (!$quick) { + defined($p) || push(@cerrors, "no \`package' line"); + $p =~ m/^$packagere$/o || &bad_control_field('package'); + defined($cf_k2v{'version'}) || push(@cerrors, "no Version field"); + for $f ('depends','recommended','optional','conflicts') { + next unless defined($cf_k2v{$f}) && length($cf_k2v{$f}); + $cf_k2v{$f} =~ m/^$singledependencyre(\s*,\s*$singledependencyre)*$/o + || &bad_control_field("$f"); + } + } + return $p; +} + +sub bad_control_field { + push(@cerrors, "bad \`$_[0]' line, contains \`$cf_k2v{$_[0]}'"); +} + +#*** bottom level of database writing code ***# + +sub write_database_file { + local ($filename, *xx_pk2v, *xx_p21, $important, @packages) = @_; + local ($p,$tl,$k,$v); + if (!@packages) { @packages= keys(%xx_p21); } + + &debug("called write_database_file $filename, important=$important, for @packages"); + if (!$important) { + open(DB,">$filename.new") || &bombout("unable to create $filename.new: $!"); + } + $tl= 0; + for $p (@packages) { + &write_database_string("\n") if $tl; + &write_database_string("Package: $p\n"); + for $k (keys %all_k21) { + next unless defined($xx_pk2v{$p,$k}); + $v= $xx_pk2v{$p,$k}; + $v =~ s/\n(\S)/\n $1/g; + &write_database_string("$k: $v\n"); + } + } + if ($important) { + if (!truncate(IMP,$tl)) { + if (print(IMP "#")) { + warn("$name: warning - unable to truncate $importantspace: $!;". + "\n commenting the rest out instead seems to have worked.\n"); + } else { + &database_corrupted("unable to truncate $importantspace: $!"); + } + } + close(IMP) || &database_corrupted("unable to close $importantspace: $!"); + rename($importantspace,$filename) || + &database_corrupted("unable to install $importantspace as $filename: $!"); + } else { + close(DB) || &bombout("unable to close $filename.new: $!"); + rename("$filename.new",$filename) || + &bombout("unable to install $filename.new as $filename: $!"); + } +} + +sub write_database_string { + $tl += length($_[0]); + if ($important) { + print(IMP $_[0]) || + &database_corrupted("failed write to update file $importantspace: $!"); + } else { + print(DB $_[0]) || + &bombout("failed to write to $filename.new: $!"); + } +} + +sub database_corrupted { + &debug("corruptingstatus @_"); + print STDERR "$name - really horrible error:\n @_\n". + "Package manager status data is now out of step with installed system.\n". + "(Last action has not been recorded. Please try re-installing \`@packages'\n". + "to ensure system consistency, or seek assistance from an expert if\n". + "problems persist.)\n"; + &cleanup; exit(2); +} + +sub prepare_important_database { + open(IMP,"+>$importantspace") || &bombout("unable to create $importantspace: $!"); + select((select(IMP),$|=1)[0]); + print(IMP "#padding\n"x512) || &bombout("unable to pad $importantspace: $!"); + seek(IMP,0,0) || &bombout("unable to seek (rewind) $importantspace: $!"); + &debug("important database prepared"); +} + +sub release_important_database { + close(IMP); + unlink($importantspace) || &bombout("unable to delete $importantspace: $!"); + &debug("important database released"); +} + +#*** database lock management ***# + +sub lock_database { + # Lock the package management databases. Stale locks will + # be broken, but there is no concurrency checking on the lock- + # breaking code. + push(@cleanups,'unlink($lockmine)'); + open(PID,">$lockmine") || &bombout("failed to create new pid file $lockmine: $!"); + printf(PID "%010d\n",$$) || &bombout("failed to add pid to $lockmine: $!"); + close(PID) || &bombout("failed to close new pid file $lockmine: $!"); + unless (link($lockmine,$lockfile)) { + $! == &EEXIST || &bombout("failed to create lock on packages database: $!"); + if (open(PID,"<$lockfile")) { + undef $/; $opid= <PID>; $/="\n"; + $opid =~ m/^\d{10}\n$/ || &lockfailed(" (pid missing)"); + close(PID); + -d '/proc/self' || + &bombout("/proc/self not found ($!) - /proc not mounted ?"); + -d sprintf("/proc/%d",$opid) && &lockfailed(" (in use by pid $opid)"); + if (open(PID,"<$lockfile")) { + $opid eq <PID> || &lockfailed(' (pid changed)'); + close(PID); + unlink($lockfile) || + &bombout("failed to break stale lock on database: $!"); + print STDERR + "$name: stale lock found on packages database, lock forced\n"; + } else { + $!==&ENOENT || + &bombout("failed to confirm who owns lock on database: $!"); + } + } else { + $!==&ENOENT || &bombout("failed to determine who owns lock on database: $!"); + } + link($lockmine,$lockfile) || + &bombout("failed to create lock on packages database: $!"); + } + push(@cleanups, 'unlink($lockfile) || + warn("$name: failed to unlock packages database: $!\n")'); + unlink($lockmine); +} + +sub unlock_database { + unlink($lockfile) || &bombout("failed to unlock packages database: $!"); + pop(@cleanups); +} + +#*** error handling ***# + +sub lockfailed { &bombout("unable to lock packages database@_"); } +sub bombout { print STDERR "$name - critical error: @_\n"; &cleanup; exit(2); } +sub badusage { print STDERR "$name: @_\n\n"; &usage; &cleanup; exit(3); } + +sub outerr { + &bombout("failed write to stdout: $!"); +} + +sub cleanup { + while (@cleanups) { + eval(pop(@cleanups)); + $@ && print STDERR "error while cleaning up: $@"; + } +} + +sub debug { + return unless $debug; + print "D: @_\n"; +} + +sub ecode { + local ($w,$s) = ($?,$!); + &debug("ecode $w syserr $s"); + return +# (($w & 0x0ffff) == 0x0ff00 ? "problems running program - exit code -1" : +# ($w & 0x0ff) == 0 ? "exit status ".(($w & 0x0ff00) >> 8) : +# ($w & 0x0ff) == 0x07f ? "stopped by signal ".(($w & 0x0ff00) >> 8) : +# "killed by signal ".($w & 0x07f).($w & 0x080 ? " (core dumped)" : '')). + (&WIFEXITED($w) ? "exit status ".&WEXITSTATUS($w) : + &WIFSIGNALED($w) ? "killed by signal ".&WTERMSIG($w). + (&WCOREDUMP($w) ? " (core dumped)" : ""): + &WIFSTOPPED($w) ? "stopped due to signal ".&WSTOPSIG($w) : + "unknown status $w"). + ($s ? ", system error $s" : ''); +} + +#*** miscellaneous helpful routines ***# + +sub readall { + local ($fh) = @_; + local ($r,$n,$this) = ''; + for (;;) { + defined($n=read($fh,$this,4096)) || return undef; + $n || last; + $r.= $this; + } + return $r; +} + +#sub debug_compare_verrevs { +# local (@i)= @_; +# local ($i)= &x_compare_verrevs(@i); +# &debug("compare_verrevs >@i< = >$i<"); +# return $i; +#} + +sub compare_verrevs { + local ($av,$ar,$bv,$br,$c) = @_; + $c = &compare_vnumbers($av,$bv); return $c if $c; + return &compare_vnumbers($ar,$br); +} + +sub compare_vnumbers { + local ($a, $b) = @_; + do { + $a =~ s/^\D*//; $ad= $&; $ad =~ s/\W/ /g; + $b =~ s/^\D*//; $bd= $&; $bd =~ s/\W/ /g; + $cm = $ad cmp $bd; return $cm if $cm; + $a =~ s/^\d*//; $ad= $&; + $b =~ s/^\d*//; $bd= $&; + $cm = $ad <=> $bd; return $cm if $cm; + } while (length ($a) && length ($b)); + return length ($a) cmp length ($b); +} + +sub sync { + system('sync'); +} |