Re: early dpkg prototype implementation in perl
Justin Pryzby writes ("early dpkg prototype implementation in perl"):
> Apparently dpkg was initially written/prototyped in perl; does there
> exist somewhere a copy of that implementation?
Here is the ,v file from my CVS. It doesn't record most of the
history, but it's what I could easily find.
> Please Cc: me,
Normally I wouldn't but I think you've got a good excuse :-).
Ian.
head 1.2;
access;
symbols
debian_version_1_5_3:1.1
debian_version_1_5_2:1.1
debian_version_1_5_1:1.1
branch-1-40-0-personal-deviance:1.1.0.4
branch-debian-nmus:1.1.0.2
rel-1-4-0:1.1;
locks; strict;
comment @# @;
1.2
date 99.07.25.17.26.02; author ian; state dead;
branches;
next 1.1;
1.1
date 98.10.25.22.26.29; author ian; state Exp;
branches
1.1.2.1;
next ;
1.1.2.1
date 98.11.01.16.07.53; author ian; state dead;
branches;
next ;
desc
@@
1.2
log
@Make insert-version.pl work again, and used everywhere.
@
text
@#!/usr/bin/perl --
#
# dpkg: Debian GNU/Linux package maintenance utility
#
# 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.
#
$version= '0.93.15'; # This line modified by Makefile
sub version {
print STDERR <<END;
Debian GNU/Linux \`dpkg\' package handling tool version $version.
Copyright (C)1994 Matt Welsh, Carl Streeter, Ian Murdock, Ian Jackson.
This is free software; see the GNU General Public Licence version 2
or later for copying conditions. There is NO warranty.
END
}
sub usage {
print STDERR <<END;
Usage: dpkg -i|--install <opts> <.deb file name> ... | -a|--auto <dir> ...
dpkg --unpack <opts> <.deb file name> ... | -a|--auto <dir> ...
dpkg -A|--avail <opts> <.deb file name> ... | -a|--auto <dir> ...
dpkg --configure <opts> <package name> ... | -a|--auto
dpkg -r|--remove <opts> <package name> ... | -a|--auto
dpkg -l|--list <status select> [<regexp> ...]
dpkg -s|--status <status select> [<package-name> ...]
dpkg -S|--search <glob pattern> ...
dpkg -b|--build|-c|--contents|-e|--control|--info|-f|--field|
-x|--extract|-X|--vextract ... (see dpkg-deb --help)
Options: --purge --control-quiet --control-verbose --version --help
-R|--root=<directory> --admindir=<directory> --instdir=<directory>
--no-keep-old-conf --no-keep-new-conf -N|--no-also-select
--ignore-depends=<package name>,...
--conf-(same|diff|all)-(new|old|promptnew|promptold)
--force-<thing>,<thing>,... --no-force-...|--refuse-...
Status selections: --isok-[o][h] (OK, Hold; alternatives are y, n)
--want-[u][i][d][p] (Unknown, Install, Deinstall, Purge)
--stat-[nupircNO] (Not, Unpacked, Postinst-failed, Installed, Removal-failed,
Config-files, Not/Config-files, Not/Config-files/Installed)
Force things: conflicts, depends, downgrade, depends-version, prermfail,
configure-any, hold, extractfail
(default is --no-force everything, except --force-downgrade)
Use \`$dselect\' for user-friendly package management.
END
}
$instroot= '';
$controlwarn = 1;
$estatus = 0;
$filename_pattern = "*.deb";
%force= ( 'conflicts',0, 'depends',0, 'depends-version',0, 'downgrade',1,
'prermfail',0, 'postrmfail',0, 'hold',0, 'configure-any',0,
'extractfail',0 );
%selectmap_h= ('o','ok', 'h','hold', 'y','ok', 'n','hold');
%selectmap_w= ('u', 'unknown', 'i', 'install', 'd', 'deinstall', 'p', 'purge');
%selectmap_s= ('n', 'not-installed',
'u', 'unpacked',
'p', 'postinst-failed',
'i', 'installed',
'r', 'removal-failed',
'c', 'config-files',
'n', 'not-installed,config-files',
'o', 'not-installed,config-files,installed');
%selectthings= ('isok','h', 'want','w', 'stat','s');
require 'lib.pl'; # This line modified by Makefile
$0 =~ m|[^/]+$|; $name = $dpkg;
$|=1;
umask(022);
$action= 'none';
%myabbrevact= ('i','install', 'r','remove', 'A','avail',
'S','search', 'l','list', 's','status');
# $conf...[0] corresponds to `same', 1 to diff
$confusenew[0]= 0; $confprompt[0]= 0;
$confusenew[1]= 1; $confprompt[1]= 1;
# Ie, default is to prompt only when hashes differ,
# and to use new when hashes differ
while ($ARGV[0] =~ m/^-/) {
$_= shift(@@ARGV);
$noptsdone++;
if (m/^--$/) {
$noptsdone--; last;
} elsif (m/^--(install|remove|unpack|configure|avail|list|status)$/) {
&setaction($1);
} elsif (m/^--(build|contents|control|info|field|extract|vextract)$/) {
$noptsdone--; &backend($1);
} elsif (m/^--ignore-depends=($packagere(,$packagere)*)$/o) {
grep($ignore_depends{$_}=1, split(/,/,$1));
} elsif (m/^--(force|no-force|refuse)-/) {
$fvalue= ($1 eq 'force');
for $fv (split(/,/,$')) {
defined($force{$fv}) || &badusage("unknown --force option \`$fv'");
$force{$fv}= $fvalue;
}
} elsif (m/^--conf-(same|diff|all)-(new|old|promptnew|promptold)$/) {
$new= $2 eq 'new' || $2 eq 'promptnew';
$prompt= $2 eq 'promptnew' || $2 eq 'promptold';
if ($1 ne 'same') { $confusenew[1]= $new; $confprompt[1]= $prompt; }
if ($1 ne 'diff') { $confusenew[0]= $new; $confprompt[0]= $prompt; }
} elsif (m/^--(\w+)-(\w+)$/ && defined($selectthings{$1})) {
$thisname= $1;
$thisthing= $selectthings{$thisname};
$_=$2;
eval '%thismap= %selectmap_'.$thisthing;
while (s/^.//) {
if (!defined($thismap{$&})) {
&badusage("unknown status letter $& for status field $thisname");
}
$thiscodes= $thismap{$&};
$selectdo.= "undef \$select_$thisthing;";
for $v (split(m/,/, $thiscodes)) {
$selectdo .= "\$select_$thisthing{'$v'}=1;";
}
}
} elsif (m/^--root=/) {
$instroot=$'; &setadmindir("$instroot/$orgadmindir");
} elsif (m/^--admindir=/) {
&setadmindir("$'");
} elsif (m/^--instdir=/) {
$instroot=$';
} elsif (m/^--auto$/) {
$auto= 1;
} elsif (m/^--purge$/) {
$purge= 1;
} elsif (m/^--skip-same-version$/) {
print STDERR
"Warning: dpkg --skip-same-version not implemented, will process\n".
" process even packages the same version of which is installed.\n";
} elsif (m/^--no-also-select$/) {
$noalsoselect= 1;
} elsif (m/^--control-verbose$/) {
$controlwarn= 1;
} elsif (m/^--control-quiet$/) {
$controlwarn= 0;
} elsif (m/^--no-keep-old-conf$/) {
$nokeepold= 1;
} elsif (m/^--no-keep-new-conf$/) {
$nokeepnew= 1;
} elsif (m/^--succinct-prompts$/) {
$succinct= 1;
} elsif (m/^--debug$/) {
$debug= 1;
} elsif (m/^--help$/) {
&usage; exit(0);
} elsif (m/^--version$/) {
&version; exit(0);
} elsif (m/^--/) {
&badusage("unknown option \`$_'");
} else {
s/^-//; $noptsdone--;
while (s/^.//) {
$noptsdone++;
if (defined($myabbrevact{$&})) {
&setaction($myabbrevact{$&});
} elsif (defined($debabbrevact{$&})) {
$noptsdone--; &backend($debabbrevact{$&});
} elsif ($& eq 'a') {
$auto= 1;
} elsif ($& eq 'D') {
$debug= 1;
} elsif ($& eq 'N') {
$noautoselect= 1;
} elsif ($& eq 'R') {
s/^=// || &badusage("missing value for -R=<dir> option");
$instroot= $_; &setadmindir("$instroot/$orgadmindir"); $_='';
} else {
&badusage("unknown option \`-$&'");
}
}
}
}
$action eq 'none' && &badusage("an action must be specified");
&debug("arguments parsed");
#*** list, status or search - the nonactive operations ***#
if ($action eq 'list' || $action eq 'status') {
&database_start;
if ($action eq 'list' || !@@ARGV) {
&selectall(*selectmap_h,*select_h);
&selectall(*selectmap_w,*select_w);
&selectall(*selectmap_s,*select_s);
if (@@ARGV) { $select_s{'not-installed'}=0; }
}
$ecode= 0;
if ($action eq 'status') {
for ($i=0;$i<=$#keysortorder;$i++) {
$keysortorder{$keysortorder[$i]}= sprintf("%6d ",$i);
# &debug("set $i: $keysortorder[$i], sortorder ".
# "\`$keysortorder{$keysortorder[$i]}'");
}
@@ARGV= &applyselcrit(sort keys %st_p21) unless @@ARGV;
for $p (@@ARGV) {
if (!$st_p21{$p}) {
print(STDERR "$name: no information available about package $p\n")
|| &bombout("writing to stderr: $!");
$ecode= 1;
}
print("Package: $p\n",
"Status: $st_p2w{$p} $st_p2h{$p} $st_p2s{$p}\n") || &outerr;
for $k (sort { $keysortorder{$a}.$a cmp $keysortorder{$b}.$b; }
keys %all_k21) {
# &debug("field $k, sortorder \`$keysortorder{$k}'");
next unless defined($st_pk2v{$p,$k});
$v= $st_pk2v{$p,$k}; next unless length($v);
if ($k eq 'conffiles' || $k eq 'list') {
$v= sprintf("(%d files, not listed)",
scalar(grep(m/\S/, split(/\n/,$v))));
}
print("$k: $v\n") || &outerr;
}
if (defined($av_p21{$p})) {
print("\n\`Available' version of package $p, where different:\n")
|| &outerr;
for $k (keys %all_k21) {
next unless defined($av_pk2v{$p,$k});
$v= $st_pk2v{$p,$k}; next unless length($v);
$u= $st_pk2v{$p,$k}; next if $u eq $v;
print("$k: $v\n") || &outerr;
}
print("\n") || &outerr;
}
}
} else { # $action eq 'list'
$listhead=0;
if (@@ARGV) {
for $r (@@ARGV) {
&listinfo(&applyselcrit(sort grep(m/$r/,keys %st_p21)));
}
} else {
undef $r;
&listinfo(&applyselcrit(sort keys %st_p21));
}
}
&database_finish;
exit($ecode);
}
sub listinfo {
if (!@@_) {
print(STDERR
defined($r) ?
"No selected packages found matching regexp \`$r'.\n" :
"No packages matched selection criteria.\n") ||
&bombout("writing to stderr: $!");
return;
}
if (!$listhead) {
print <<END
Err? Name Version Rev Description
| Status=Not/Unpacked/Postinst-failed/Installed/Removal-failed/Config-files
|/ Desired=Unknown/Install/Deinstall/Purge
||/ | | | |
+++-============-==========-===-===============================================
END
|| &outerr;
$listhead= 1;
}
for $p (@@_) {
$des= $st_pk2v{$p,'description'};
$des= $` if $des =~ m/\n/;
printf("%s%.1s%.1s %-12.12s %-10.10s %-3.3s %-47.47s\n",
$st_p2h{$p} eq 'hold' ? 'x' : ' ', $st_p2s{$p}, $st_p2w{$p},
$p, $st_pk2v{$p,'version'}, $st_pk2v{$p,'package_revision'},
$des);
}
}
sub applyselcrit {
&debug("sel from @@_");
for $f (@@_) { &debug("$f :$st_p2s{$f},$select_s{$st_p2s{$f}}:$st_p2w{$f},$select_w{$st_p2w{$f}}:$st_p2h{$f},$select_h{$st_p2h{$f}}:"); }
@@ascr= grep($select_s{$st_p2s{$_}} &&
$select_w{$st_p2w{$_}} &&
$select_h{$st_p2h{$_}},
@@_);
&debug("sel gave @@ascr");
@@ascr;
}
sub selectall {
local (*map, *sel) = @@_;
local ($v);
for $v (values %map) {
next if m/,/;
$sel{$v}=1;
}
}
if ($action eq 'search') {
@@ARGV || &badusage("need at least one glob pattern for --$action");
&database_start;
while (@@ARGV) {
$orgpat= $_= shift(@@ARGV);
s/\W/\\$&/g;
s|\\\*\\\*|.*|g;
s|\\\*|[^/]*|g;
s|\\\?|[^/]|g;
$pat= $_; $f=0;
for $p (sort keys %st_p21) {
$s= $st_p2s{$p};
next if $s eq 'not-installed' || $s eq 'config-files';
&filesinpackage($arg, $package);
@@ilist= grep(m/^$pat$/,@@ilist);
next unless @@ilist;
$f=1;
for $_ (@@ilist) { print("$p: $_\n") || &outerr; }
}
if (!$f) {
print(STDERR "No packages found containing \`$orgpat'.\n")
|| &bombout("writing to stderr: $!");
$ecode= 1;
}
}
&database_finish;
exit($ecode);
}
#*** lock and read in databases ***#
&database_start;
&debug("databases read");
#*** derive argument list for --auto ***#
if ($auto) {
if ($action eq 'install' || $action eq 'unpack' || $action eq 'avail') {
@@ARGV || &badusage("need at least one directory for --$action --auto");
pipe(RP,WP) || &bombout("create pipe for \`find': $!");
defined($c= fork) || &bombout("fork for \`find': $!");
if (!$c) {
close(RP); open(STDOUT,">& WP"); close(WP);
exec('find',@@ARGV,'-name',$filename_pattern,'-type','f','-print0');
die "$name: could not exec \`find': $!";
}
close(WP);
$/="\0"; @@ARGV= <RP>; $/="\n";
eof || &bombout("read filenames from \`find': $!");
close(RP);
$!=0; waitpid($c,0) eq $c || &bombout("wait for \`find' failed: $!");
$? && &bombout("\`find' process returned error code ".&ecode);
@@ARGV || &bombout("no packages found to $action");
} else {
@@ARGV && &badusage("no package names may be specified with --$action --auto");
if ($action eq 'remove') {
eval 'sub condition {
$wants eq "deinstall" || $wants eq "purge" || return 0;
$cstatus eq "not-installed" && return 0;
$cstatus eq "config-files" && $wants eq "deinstall" && return 0;
return 1;
} 1;' || &internalerr("sub condition: $@@");
} elsif ($action eq 'configure') {
eval 'sub condition {
$wants eq "install" || return 0;
$cstatus eq "unpacked" || $cstatus eq "postinst-failed" || return 0;
return 1;
} 1;' || &internalerr("sub condition: $@@");
} else {
&internalerr("unknown auto nonames action $action");
}
for $p (keys %st_p21) {
next if $st_p2h{$p} eq 'hold';
$wants= $st_p2w{$p}; $cstatus= $st_p2s{$p};
next unless &condition;
push(@@ARGV,$p);
}
}
&debug("auto: arglist @@ARGV");
} else {
@@ARGV || &badusage("need a list of packages or filenames");
}
if ($action eq 'install' || $action eq 'unpack') {
grep(s:^[^/.]:./$&:, @@ARGV); # Sanitise filenames
}
&debug("action: $action; arglist @@ARGV");
#*** actually do things ***#
for $arg (@@ARGV) {
$package= ''; @@undo=();
&debug("&do_$action($arg)");
if (!eval "&do_$action(\$arg); 1;") { &handleerror || last; }
&checkpointstatus;
}
&checkpointstatus;
if (!$abort) {
&debug("&middle_$action($arg)");
if (!eval "&middle_$action; 1;") { print STDERR $@@; $abort=1; }
}
&checkpointstatus;
if (!$abort) {
while (@@deferred) {
$arg= shift(@@deferred); $package= ''; @@undo=();
&debug("&deferred_$action($arg) ($dependtry: $sincenothing)");
if (!eval "&deferred_$action(\$arg); 1;") { &handleerror || last; }
&checkpointstatus;
}
&checkpointstatus;
}
if ($errors) {
print STDERR "$name: $errors errors occurred.\n";
$estatus= 1;
}
&database_finish;
&cleanup;
exit($estatus);
#*** useful subroutines for main control section ***#
sub handleerror {
print STDERR $@@;
if (length($package) && defined($st_p21{$package})) {
$st_p2h{$package}='hold'; &amended_status($package);
}
$errors++;
if ($errors >20) { print STDERR "$name: too many errors, halting\n"; return 0; }
return !$abort;
}
sub checkpointstatus {
return unless keys %statusupdated;
&amended_status(keys %statusupdated);
undef %statusupdated;
}
sub backend {
&setaction('');
($noptsdone) && &badusage("action \`$_[0]' must be first argument");
&debug("backend --$_[0]");
exec($backend, "--$_[0]", @@ARGV);
&bombout("unable to run $backend: $!");
}
sub setaction {
$action eq 'none' || &badusage("conflicting actions \`$action' and \`$1'");
$action= $_[0];
}
#*** error handlers for use in actions ***#
sub warn { warn "$name - warning: @@_\n"; }
sub subcriterr { warn "$name - subcritical error: @@_\n"; $estatus=1; }
sub error { &acleanup; die "$name - error: @@_\n"; }
sub internalerr { &acleanup; die "$name - internal error, please report: @@_\n"; }
sub fatalerr { &acleanup; die "$name - fatal error, halting: @@_\n"; $abort=1; }
sub corruptingerr {
local ($corruptingerr)= @@_;
&acleanup;
die "$name - horrible error: $corruptingerr;\n".
"Package manager data is now out of step with installed system.\n".
"Please re-install \`$package' to ensure system consistency!\n".
"(Seek assistance from an expert if problems persist.)\n";
$abort=1;
}
sub forcibleerr {
local ($msg,@@forces) = @@_;
if (@@forces= grep($force{$_},@@forces)) {
&warn("$msg (proceeding due to --force-$forces[0])");
} else {
&error("$msg (skipping this package)");
}
}
sub acleanup {
while (@@undo) {
eval(pop(@@undo));
$@@ && print STDERR "error while cleaning up: $@@";
}
}
#*** --install ***#
sub do_install {
&do_unpack($arg);
$arg= $package;
&do_configure($arg);
}
sub deferred_install { &deferred_configure; }
sub middle_install { &middle_configure }
#*** --avail ***#
sub do_avail {
unlink($controli);
if ($! != &ENOENT) {
system('rm','-rf',$controli);
unlink($controli);
$! == &ENOENT || &fatalerr("unable to get rid of $controli: $!");
}
&debug("extract control $backend --control $arg $controli");
$!=0; system($backend,"--control",$arg,$controli);
$? && &error("$arg: could not extract control information (".&ecode.")");
open(CONTROL,"$controli/control") ||
&error("$arg: corrupt - unable to read control file: $!");
&parse_control("$arg");
for $k (keys %cf_k2v) {
$av_pk2v{$p,$k}= $cf_k2v{$k};
}
for $k (@@nokeepfields) {
delete $av_pk2v{$p,$k} unless defined($cf_k2v{$k});
}
&amended_available($p);
$package=$p;
}
sub deferred_avail { }
sub middle_avail { }
#*** --unpack ***#
sub middle_unpack { }
sub do_unpack {
&do_avail;
$cstatus= $st_p2s{$package};
if ($st_p2w{$package} ne 'install') {
if (!$noalsoselect) {
$st_p2w{$package}= 'install'; $statusupdated{$package}= 1;
print STDOUT "Selecting previously deselected package $package.\n";
} else {
print STDOUT "Skipping deselected package $package.\n";
return;
}
}
for $tp (split(/,/, $av_pk2v{$package,'conflicts'})) {
$tp =~ s/^\s*//; $tp =~ s/\s+$//;
($tps, $rightver, $inst, $want, $tpp)= &installationstatus($tp);
unless ($tps eq 'not-installed' || $tps eq 'config-files' || !$rightver) {
&forcibleerr("$arg: conflicts with package $tpp ($want),".
" found $inst on system",
'conflicts');
}
}
if ($cstatus eq 'installed') {
if (&compare_verrevs($av_pk2v{$package,'version'},
$av_pk2v{$package,'package_revision'},
$st_k2v{'version'},$st_k2v{'package_revision'}) <0) {
&forcibleerr("$arg: downgrading installed $package version ".
"$st_k2v{'version'}, ".
"package revision $st_k2v{'package_revision'} ".
"to older version ".
"$av_pk2v{$package,'version'}, ".
"package revision $av_pk2v{$package,'package_revision'}",
'downgrade');
}
}
if (open(CONF,"$controli/conffiles")) {
@@configf= <CONF>;
eof || &error("$arg: unable to read $controli/conffiles: $!");
close(CONF);
grep((chop, m,^/, || s,^,/,), @@configf);
} elsif ($! != &ENOENT) {
&error("$arg: cannot get config files list: $!");
} else {
@@configf= ();
}
if ($cstatus eq 'installed' || $cstatus eq 'unpacked' ||
$cstatus eq 'postinst-failed' || $cstatus eq 'removal-failed') {
&filesinpackage($arg,$package);
print STDOUT "Preparing to replace $package ...\n";
}
if ($cstatus eq 'installed') {
if (!eval {
&run_script_ne("$scriptsdir/$package.prerm", 'old pre-removal script',
'upgrade',
$av_pk2v{$package,'version'}.'-'.
$av_pk2v{$package,'package_revision'});
1;
}) {
&warn("$@@... trying script from new package instead.");
&run_script("$controli/prerm", 'new prerm script',
'failed-upgrade',
$st_k2v{'version'}.'-'.$st_k2v{'package_revision'});
}
push(@@undo,
'$st_p2s{$package}= "postinst-failed"; $statusupdated{$package}=1;
&run_script_ne("$scriptsdir/$package.postinst",
"old post-installation script",
"abort-upgrade",
$av_pk2v{$package,"version"}."-".
$av_pk2v{$package,"package_revision"});
$st_p2s{$package}= "installed"; $statusupdated{$package}=1;');
}
@@fbackups=();
if ($cstatus eq 'installed' || $cstatus eq 'unpacked' ||
$cstatus eq 'postinst-failed' || $cstatus eq 'removal-failed') {
for ($i=0; $i<=$#ilist; $i++) {
next if grep($_ eq $ilist[$i], @@configf);
$_= $ilist[$i];
unless (lstat("$instroot/$_")) {
$! == &ENOENT || &error("old file $_ unstattable: $!");
next;
}
next if -d _;
rename("$instroot/$_","$instroot/$_.dpkg-tmp") ||
&error("couldn't rename old file $_ to $_.dpkg-tmp: $!");
push(@@undo,
'$_=pop(@@fbackups); rename("$instroot/$_.dpkg-tmp","$instroot/$_") ||
die "unable to undo rename of $_ to $_.dpkg-tmp: $!"');
push(@@fbackups, $_);
}
if (!eval {
&run_script_ne("$scriptsdir/$package.postrm", 'old post-removal script',
'upgrade',
$av_pk2v{$package,'version'}.'-'.
$av_pk2v{$package,'package_revision'});
1;
}) {
&warn("$@@... trying script from new package instead.");
&run_script("$controli/postrm", 'new post-removal script',
'failed-upgrade',
$st_k2v{'version'}.'-'.$st_k2v{'package_revision'});
}
push(@@undo,
'&run_script_ne("$scriptsdir/$package.preinst",
"old pre-installation script",
"abort-upgrade",
$av_pk2v{$package,"version"}.
"-".$av_pk2v{$package,"package_revision"})');
}
$shortarg= $arg; $shortarg =~ s:.{15,}/:.../:;
print STDOUT "Unpacking $arg, containing $package ...\n";
&run_script("$controli/preinst", 'pre-installation script',
'upgrade', $st_k2v{'version'}.'-'.$st_k2v{'package_revision'});
push(@@undo,'&run_script_ne("$controli/postrm", "post-removal script",
"abort-upgrade",
$st_k2v{"version"}."-".$st_k2v{"package_revision"})');
if ($cstatus ne 'not-installed') {
for $_ (split(/\n/,$st_pk2v{$package,'conffiles'})) {
s/^ //; next unless length($_);
if (!m/^(\S+) (-|newconffile|nonexistent|[0-9a-f]{32})$/) {
&warn("$arg: ignoring bad stuff in old conffiles field \`$_'");
next;
}
$oldhash{$1}= $2;
}
}
for $f (@@configf) {
$drf= &conffderef($f); if (!defined($drf)) { next; }
if (lstat("$instroot/$drf.dpkg-tmp")) {
$undo=1;
} else {
$! == &ENOENT || &error("unable to stat backup config file $_.dpkg-tmp: $!");
if (lstat("$instroot/$drf")) {
rename("$instroot/$drf","$instroot/$drf.dpkg-tmp") ||
&error("couldn't back up config file $f (= $drf): $!");
$undo=1;
} elsif ($! == &ENOENT) {
$undo=0;
} else {
&error("unable to stat config file $drf: $!");
}
}
if ($undo) {
push(@@undo,
'$_=pop(@@undof); rename("$instroot/$_.dpkg-tmp","$instroot/$_") ||
die "unable to undo backup of config file $_: $!"');
push(@@undof, $drf);
}
}
open(NL,">$listsdir/$package.list.new") ||
&error("$package: cannot create $listsdir/$package.list.new: $!");
defined($c= fork) || &error("$package: cannot pipe/fork for $backend --vextract");
if (!$c) {
if (!open(STDOUT,">&NL")) {
print STDERR "$name: cannot redirect stdout: $!\n"; exit(1);
}
$vexroot= length($instroot) ? $instroot : '/';
exec($backend,"--vextract",$arg,$vexroot);
print STDERR "$name: cannot exec $backend --vextract $arg $vexroot: $!\n";
exit(1);
}
$!=0; waitpid($c,0) == $c || &error("could not wait for $backend: $!");
$? && &forcibleerr("$package: failed to install (".&ecode.")", 'extractfail');
rename("$listsdir/$package.list.new","$listsdir/$package.list") ||
&error("$package: failed to install new $listsdir/$package.list: $!");
$newconff='';
for $f (@@configf) {
$h= $oldhash{$f};
$h='newconffile' unless length($h);
$newconff.= "\n $f $h";
&debug("new hash, after unpack, of $f, is $h");
}
for $k (keys %all_k21) {
next if $k eq 'binary' || $k eq 'source' || $k eq 'section';
$st_pk2v{$package,$k}= $av_pk2v{$package,$k};
}
$st_pk2v{$package,'conffiles'}= $newconff; $all_k21{'conffiles'}= 1;
$st_p2s{$package}= 'unpacked'; $st_p2h{$package}= 'ok'; $st_p21{$package}= 1;
$statusupdated{$package}= 1;
@@undo=(); @@undof=();
for $f (@@fbackups) {
unlink("$instroot/$f.dpkg-tmp") || $! == &ENOENT ||
&subcriterr("$package: unable to delete saved old file $f.dpkg-tmp: $!\n");
}
undef %fordeletion;
opendir(PI,"$scriptsdir") ||
&corruptingerr("$package: unable to read $scriptsdir directory ($!)");
while(defined($_=readdir(PI))) {
next unless substr($_,0,length($package)+1) eq $package.'.';
$fordeletion{$_}= 1;
}
closedir(PI);
opendir(PI,"$controli") ||
&corruptingerr("$package: unable to read $controli".
" new package control information directory ($!)");
$fordeletion{"$package.list"}= 0;
while(defined($_=readdir(PI))) {
next if m/^\.\.?$/ || m/^conffiles$/ || m/^control$/;
rename("$controli/$_","$scriptsdir/$package.$_") ||
&corruptingerr("$package: unable to install new package control".
" information file $scriptsdir/$package.$_ ($!)");
$fordeletion{"$package.$_"}= 0;
}
closedir(PI);
for $_ (keys %fordeletion) {
next unless $fordeletion{$_};
unlink("$scriptsdir/$_") ||
&corruptingerr("$package: unable to remove old package script".
" $scriptsdir/$_ ($!)");
}
}
#*** --configure ***#
sub do_configure {
$package=$arg; $cstatus= $st_p2s{$package};
if (!defined($st_p21{$package})) { $cstatus= 'not-installed'; }
unless ($cstatus eq 'unpacked' || $cstatus eq 'postinst-failed') {
if ($cstatus eq 'not-installed') {
&error("no package named \`$package' is installed, cannot configure");
} else {
&error("$package: is currently in state \`$cstatus', cannot configure");
}
}
push(@@deferred,$package);
}
sub middle_configure {
$sincenothing=0; $dependtry=1;
}
sub deferred_configure {
# The algorithm for deciding what to configure first is as follows:
# Loop through all packages doing a `try 1' until we've been round
# and nothing has been done, then do `try 2' and `try 3' likewise.
# Try 1:
# Are all dependencies of this package done ? If so, do it.
# Are any of the dependencies missing or the wrong version ?
# If so, abort (unless --force-depends, in which case defer)
# Will we need to configure a package we weren't given as an
# argument ? If so, abort - except if --force-configure-any,
# in which case we add the package to the argument list.
# If none of the above, defer the package.
# Try 2:
# Find a cycle and break it (see above).
# Do as for try 1.
# Try 3 (only if --force-depends-version).
# Same as for try 2, but don't mind version number in dependencies.
# Try 4 (only if --force-depends).
# Do anyway.
$package= $arg;
if ($sincenothing++ > $#deferred*2+2) {
$dependtry++; $sincenothing=0;
&internalerr("$package: nothing configured, but try was already 4 !")
if $dependtry > 4;
}
if ($dependtry > 1) { &findbreakcycle($package); }
($ok, @@aemsgs) = &dependencies_ok($package,'');
if ($ok == 1) {
push(@@deferred,$package); return;
} elsif ($ok == 0) {
$sincenothing= 0;
&error("$arg: dependency problems - not configuring this package:\n ".
join("\n ",@@aemsgs));
} elsif (@@aemsgs) {
&warn("$arg: dependency problems, configuring anyway as you request:\n ".
join("\n ",@@aemsgs));
}
$sincenothing= 0;
print STDOUT "Setting up $package ...\n";
if ($st_p2s{$package} eq 'unpacked') {
&debug("conffiles updating >$st_pk2v{$package,'conffiles'}<");
undef %oldhash; @@configf=();
for $_ (split(/\n/,$st_pk2v{$package,'conffiles'})) {
s/^ //; next unless length($_);
if (!m/^(\S+) (-|newconffile|nonexistent|[0-9a-f]{32})$/) {
&warn("$arg: ignoring bad stuff in old conffiles field \`$_'");
next;
}
$oldhash{$1}= $2; push(@@configf,$1);
&debug("old hash of $1 is $2");
}
undef %newhash;
for $file (@@configf) {
$drf= &conffderef($file);
if (!defined($drf)) { $newhash{$file}= '-'; next; }
$newhash{$file}= &hash("$instroot/$drf");
&debug("new hash of $file is $newhash{$file} (old $oldhash{$file})");
if ($oldhash{$file} eq 'newconffile') {
$usenew= 1;
} else {
if (!&files_not_identical("$instroot/$drf",
"$instroot/$drf.dpkg-tmp")) {
rename("$instroot/$drf.dpkg-tmp",$drf) || $!==&ENOENT ||
&error("$package: unable to reinstall ".
"existing conffile $drf.dpkg-tmp: $!");
&debug("files identical $file");
} else {
$diff= $newhash{$file} ne $oldhash{$file};
$usenew= $confusenew[$diff];
&debug("the decision - diff $diff;".
" usenew $usenew prompt $confpromt[$diff]");
if ($confprompt[$diff]) {
$symlinked = $drf eq $file ? '' :
$succinct ? " (-> $drf)" :
" (which is a symlink to $drf)";
for (;;) {
print
$succinct ? "
Package $package, file $file$symlinked, ".($diff ? "CHANGED": "not changed")
: $diff ? "
In package $package, distributed version of configuration
file $file$symlinked has changed
since the last time it was installed. You may:
* Install the new version and edit it later to reflect your wishes.
". ($nokeepold ?
"(Your old version will not be saved.)" :
"(Your old version will be saved in $drf.dpkg-old.)") . "
* Leave your old version in place, and perhaps check later that
you don't want to update it to take account of new features.
". ($nokeepnew ?
"(The new version be discarded.)" :
"(The new version will be placed in $drf.dpkg-new.)")
: "
Package $package contains the same distributed version of
configuration file $file$symlinked
as the last time it was installed. You may:
* Install the distributed version, overwriting your changes.
". ($nokeepold ?
"(Your changed version will not be saved.)" :
"(Your changed version will be saved in $drf.dpkg-old.)") . "
* Leave your own version in place.
". ($nokeepnew ?
"(The distributed version be discarded.)" :
"(The distributed version will be placed in $drf.dpkg-new.)");
print "
$file: install new version ? (y/n, default=". ($usenew?'y':'n'). ") ";
$!=0; defined($iread= <STDIN>) ||
&error("$package: prompting, EOF/error on stdin: $!");
$_= $iread; s/^\s*//; s/\s+$//;
($usenew=0, last) if m/^n(o)?$/i;
($usenew=1, last) if m/^y(es)?$/i;
last if m/^$/;
print "\nPlease answer \`y' or \`n'.\n";
}
}
&debug("decided, usenew $usenew");
if ($usenew) {
©perm("$drf.dpkg-tmp",$drf,$drf);
if ($nokeepold) {
unlink("$instroot/$drf.dpkg-tmp") || $!==&ENOENT ||
&error("$package: unable to delete old conffile ".
"$drf.dpkg-tmp: $!");
unlink("$instroot/$drf.dpkg-old") || $!==&ENOENT ||
&error("$package: unable to delete very old ".
"conffile $drf.dpkg-old: $!");
} else {
rename("$instroot/$drf.dpkg-tmp","$instroot/$drf.dpkg-old")
|| $!==&ENOENT ||
&error("$package: unable to back up old conffile ".
"$drf.dpkg-tmp as $drf.dpkg-old: $!");
}
} else {
unlink("$instroot/$drf.dpkg-new") || $!==&ENOENT ||
&error("$package: unable to delete old new conffile ".
"$drf.dpkg-new: $!");
if (!$nokeepnew) {
link("$instroot/$drf","$instroot/$drf.dpkg-new")
|| $!==&ENOENT ||
&error("$package: unable save new conffile ".
"$drf as $drf.dpkg-new: $!");
}
if (!rename("$instroot/$drf.dpkg-tmp","$instroot/$drf")) {
$!==&ENOENT || &error("$package: unable reinstall old ".
"conffile $drf.dpkg-tmp as $drf: $!");
unlink("$instroot/$drf");
}
}
}
}
}
$newconff='';
for $f (@@configf) {
$h= $newhash{$f}; $newconff.= "\n $f $h";
}
$st_pk2v{$package,'conffiles'}= $newconff; $all_k21{'conffiles'}= 1;
}
$st_p2s{$package}= 'postinst-failed'; $statusupdated{$package}= 1;
&run_script("$scriptsdir/$package.postinst",
'post-installation script', 'configure');
$st_p2s{$package}= 'installed';
$st_p2h{$package}= 'ok'; $statusupdated{$package}= 1;
}
#*** --remove ***#
sub do_remove {
$package=$arg; $cstatus= $st_p2s{$package};
if (!defined($st_p21{$package}) ||
$cstatus eq 'not-installed' ||
!$purge && $cstatus eq 'config-files') {
&error("$package: is not installed, cannot remove");
}
push(@@deferred,$package);
if (!$auto) {
$ns= $purge ? 'purge' : 'deinstall';
if ($st_p2w{$package} ne $ns) {
$st_p2w{$package}= $ns; $statusupdated{$package}= 1;
}
}
}
sub middle_remove {
$sincenothing=0; $dependtry=1;
for $p (keys %st_p2s) {
$cstatus= $st_p2s{$p};
next unless $cstatus eq 'installed';
for $tp (split(/[\|,]/, $st_pk2v{$p,'depends'})) {
$tp =~ s/\s*\(.+\)\s*$//; $tp =~ s/^\s*//; $tp =~ s/\s+$//;
$tp =~ m/^$packagere$/o ||
&internalerr("package $p dependency $tp didn't match re");
$depended{$tp}.= "$p ";
}
}
}
sub deferred_remove {
$package= $arg;
if ($sincenothing++ > $#deferred*2+2) {
$dependtry++; $sincenothing=0;
&internalerr("$package: nothing configured, but try was already 4 !")
if $dependtry > 4;
}
@@raemsgs= (); $rok= 2;
&debug("$package may be depended on by any of >$depended{$package}<");
for $fp (split(/ /, $depended{$package})) {
next if $fp eq '' || $ignore_depends{$tp};
$is= $st_p2s{$fp};
next if $is eq 'not-installed' || $is eq 'unpacked' ||
$is eq 'removal-failed' || $is eq 'config-files';
if ($dependtry > 1) { &findbreakcycle($fp); }
($ok, @@aemsgs) = &dependencies_ok($fp,$package);
if ($rok != 1) { push(@@raemsgs,@@aemsgs); }
$rok= $ok if $ok < $rok;
}
if ($rok == 1) {
push(@@deferred,$package); return;
} elsif ($rok == 0) {
$sincenothing= 0;
&error("$arg: dependency problems - not removing this package:\n ".
join("\n ",@@raemsgs));
} elsif (@@raemsgs) {
&warn("$arg: dependency problems, removing anyway as you request:\n ".
join("\n ",@@raemsgs));
}
$sincenothing= 0;
&filesinpackage($arg,$package);
undef %hash; @@configfr= @@configf= ();
for $_ (split(/\n/,$st_pk2v{$package,'conffiles'})) {
s/^ //; next unless length($_);
if (!m/^(\S+) (-|newconffile|nonexistent|[0-9a-f]{32})$/) {
&warn("$arg: ignoring bad stuff in old conffiles field \`$_'");
next;
}
unshift(@@configfr,$1); push(@@configf,$1);
$hash{$1}= $2;
}
if ($st_p2s{$package} ne 'config-files') {
print STDOUT "Removing $package ...\n";
&run_script("$scriptsdir/$package.prerm", 'pre-removal script', 'remove');
$st_p2s{$package}= 'removal-failed'; $statusupdated{$package}= 1;
for $file (reverse @@ilist) {
next if grep($_ eq $file, @@configf);
unlink("$instroot/$file.dpkg-tmp") || $! == &ENOENT ||
&error("$arg: cannot remove supposed old temp file $file: $!");
next if unlink("$instroot/$file");
next if $! == &ENOENT;
&error("$arg: cannot remove file $file: $!") unless $! == &EISDIR;
next if rmdir("$instroot/$file");
&error("$arg: cannot remove directory $file: $!") unless $! == &ENOTEMPTY;
}
&run_script("$scriptsdir/$package.postrm", 'post-removal script', 'remove');
opendir(DSD,"$scriptsdir") ||
&error("$arg: cannot read directory $scriptsdir: $!");
for $_ (readdir(DSD)) {
next unless m/\.[^.]$/;
next if $& eq '.postrm' || $& eq '.list';
# need postrm for --purge, and list has to go last in case it
# goes wrong
next unless $` eq $package;
unlink("$scriptsdir/$_") ||
&error("$arg: unable to delete control information $scriptsdir/$_: $!");
}
closedir(DSD);
$st_p2s{$package}= 'config-files';
$statusupdated{$package}= 1;
}
if ($purge) {
print STDOUT "Purging configuration files for $package ...\n";
push(@@undo,
'$newconff="";
for $f (@@configf) { $newconff.= "\n $f $hash{$f}"; }
$st_pk2v{$package,"conffiles"}= $newconff; $all_k21{"conffiles"}= 1;');
for $file (@@configfr) {
$drf= &conffderef($file); if (!defined($drf)) { next; }
unlink("$instroot/$drf") || $! == &ENOENT ||
&error("$arg: cannot remove old config file $file (= $drf): $!");
$hash{$file}= 'newconffile';
unlink("$instroot/$file") || $! == &ENOENT ||
&error("$arg: cannot remove old config file $file: $!")
if $file ne $drf;
for $ext ('.dpkg-tmp', '.dpkg-old', '.dpkg-new', '~', '.bak', '%') {
unlink("$instroot/$drf$ext") || $! == &ENOENT ||
&error("$arg: cannot remove old config file $drf$ext: $!");
}
unlink("#$instroot/$drf#") || $! == &ENOENT ||
&error("$arg: cannot remove old auto-save file #$drf#: $!");
$drf =~ m,^(.*)/, || next; $dir= $1; $base= $';
if (opendir(CFD,"$instroot/$dir")) {
for $_ (readdir(CFD)) {
next unless m/\.~\d+~$/;
next unless $` eq $base;
unlink("$instroot/$dir/$_") || $! == &ENOENT ||
&error("$arg: cannot remove old emacs backup file $dir/$_: $!");
}
closedir(CFD);
if (grep($_ eq $dir, @@ilist)) {
rmdir("$instroot/$dir") || $! == &ENOTEMPTY ||
&error("$arg: cannot remove config file directory $dir: $!");
}
} elsif ($! != &ENOENT) {
&error("$arg: cannot read config file dir $dir: $!");
}
}
&run_script("$scriptsdir/$package.postrm", 'post-removal script for purge',
'purge');
unlink("$scriptsdir/$package.postrm") || $! == &ENOENT ||
&error("$arg: cannot remove old postrm script: $!");
&setnotinstalled;
@@undo= ();
} elsif (!@@configf && !stat("$scripts/$package.postrm")) {
# If there are no config files and no postrm script then we
# go straight into `purge'. However, perhaps the stat didn't
# fail with ENOENT ...
$! == &ENOENT || &error("$package: stat failed on postrm script: $!");
$st_p2w{$package}= 'purge';
&setnotinstalled;
}
$st_p2h{$package}= 'ok'; $statusupdated{$package}= 1;
}
sub setnotinstalled {
unlink("$listsdir/$package.list") ||
&error("$arg: unable to delete old file list: $!");
$st_p2s{$package}= 'not-installed';
for $k (keys %all_k21) { delete $st_pk2v{$package,$k}; }
}
#*** dependency processing - common to --configure and --remove ***#
# The algorithm for deciding what to configure or remove first is as
# follows:
#
# Loop through all packages doing a `try 1' until we've been round and
# nothing has been done, then do `try 2' and `try 3' likewise.
#
# When configuring, in each try we check to see whether all
# dependencies of this package are done. If so we do it. If some of
# the dependencies aren't done yet but will be later we defer the
# package, otherwise it is an error.
#
# When removing, in each try we check to see whether there are any
# packages that would have dependencies missing if we removed this
# one. If not we remove it now. If some of these packages are
# themselves scheduled for removal we defer the package until they
# have been done.
#
# The criteria for satisfying a dependency vary with the various
# tries. In try 1 we treat the dependencies as absolute. In try 2 we
# check break any cycles in the dependency graph involving the package
# we are trying to process before trying to process the package
# normally. In try 3 (which should only be reached if
# --force-depends-version is set) we ignore version number clauses in
# Depends lines. In try 4 (only reached if --force-depends is set) we
# say "ok" regardless.
#
# If we are configuring and one of the packages we depend on is
# awaiting configuration but wasn't specified in the argument list we
# will add it to the argument list if --configure-any is specified.
# In this case we note this as having "done something" so that we
# don't needlessly escalate to higher levels of dependency checking
# and breaking.
sub dependencies_ok {
local ($dp, $removingp) = @@_;
local ($tpo, $however_t, $ok, $found, @@aemsgs, @@oemsgs);
local ($tp, $rightver, $inst, $want, $thisf, $matched, $tpp);
$ok= 2; # 2=ok, 1=defer, 0=halt
&debug("checking dependencies of $dp (- $removingp)");
for $tpo (split(/,/, $st_pk2v{$dp,'depends'})) {
$tpo =~ s/^\s*//; $tpo =~ s/\s+$//;
&debug(" checking group $dp -> $tpo");
$matched= 0; @@oemsgs=();
$found=0; # 0=none, 1=defer, 2=withwarning, 3=ok
for $tp (split(/\|/, $tpo)) {
$tp =~ s/^\s*//; $tp =~ s/\s+$//;
&debug(" checking possibility $dp -> $tp");
if ($ignore_depends{$tp}) { &debug("ignoring so ok"); $found=3; last; }
if (defined($cyclebreak{$dp,$tp})) { &debug("break cycle"); $found=3; last; }
if ($tp eq $removingp) {
($tps, $rightver, $inst, $want, $tpp)= ('removing-now', 1, '','', $tp);
$matched= 1;
} else {
($tps, $rightver, $inst, $want, $tpp)= &installationstatus($tp);
&debug("installationstatus($tp) -> !$tps!$rightver!$inst!$want!$tps|");
}
if (($tps eq 'installed' || $tps eq 'unpacked' || $tps eq 'postinst-failed')
&& !$rightver) {
push(@@oemsgs,"version of $tpp on system is $inst (wanted $want)");
if ($force{'depends'}) { $thisf= $dependtry >= 3 ? 2 : 1; }
} elsif ($tps eq 'unpacked' || $tps eq 'postinst-failed') {
if (grep($_ eq $tpp, @@deferred)) {
$thisf=1;
} elsif (!length($removingp) && $force{'configure-any'}) {
&warn("will also configure $tpp");
push(@@deferred,$tpp); $sincenothing=0; $thisf=1;
} else {
push(@@oemsgs,"package $tpp is not configured yet");
if ($force{'depends'}) { $thisf= $dependtry >= 4 ? 2 : 1; }
}
} elsif ($tps eq 'installed') {
$found=3; last;
} elsif ($tps eq 'removing-now') {
push(@@oemsgs,"$tpp is to be removed");
if ($force{'depends'}) { $thisf= $dependtry >= 4 ? 2 : 1; }
} else {
push(@@oemsgs,"$tpp ($want) is not installed");
if ($force{'depends'}) { $thisf= $dependtry >= 4 ? 2 : 1; }
}
&debug(" found $found");
$found=$thisf if $thisf>$found;
}
&debug(" found $found matched $matched");
next if length($removingp) && !$matched;
if (length($removingp) && $tpo !~ m/\|/) {
$however_t= '';
} elsif (@@oemsgs > 1) {
$however_t= "\n However, ". join(",\n ", @@oemsgs[0..($#oemsgs-1)]).
" and\n ". $oemsgs[$#oemsgs]. ".";
} else {
$however_t= "\n However, @@oemsgs.";
}
if ($found == 0) {
push(@@aemsgs, "$dp depends on $tpo.$however_t");
$ok=0;
} elsif ($found == 1) {
$ok=1 if $ok>1;
} elsif ($found == 2) {
push(@@aemsgs, "$dp depends on $tpo.$however_t");
} elsif ($found != 3) {
&internalerr("found value in deferred_configure $found not known");
}
}
&debug("ok $ok msgs >>@@aemsgs<<");
return ($ok, @@aemsgs);
}
sub findbreakcycle {
# Cycle breaking works recursively down the package dependency
# tree. @@sofar is the list of packages we've descended down
# already - if we encounter any of its packages again in a
# dependency we have found a cycle.
#
# Cycles are preferentially broken by ignoring a dependency from
# a package which doesn't have a postinst script. If there isn't
# such a dependency in the cycle we break at the `start' of the
# cycle from the point of view of our package.
#
local ($package,@@sofar) = @@_;
local ($tp,$tpp,$tps,$rightver,$inst,$want,$i,$dr,$de,@@sf);
&debug("findbreakcycle($package; @@sofar)");
push(@@sofar,$package);
for $tp (split(/[,|]/, $st_pk2v{$package,'depends'})) {
$tp =~ s/^\s*//; $tp =~ s/\s+$//;
($tps, $rightver, $inst, $want, $tpp)= &installationstatus($tp);
next unless $tps eq 'config-files' || $tps eq 'unpacked';
next if $cyclebreak{$package,$tpp};
if (grep($_ eq $tpp, @@sofar)) {
&debug("found cycle $package, $tpp (@@sofar)");
@@sf= (@@sofar,$tpp);
for ($i=0;
$i<$#sf;
$i++) {
next if stat("$scriptsdir/$sf[$i].postinst");
last if $! == &ENOENT;
&error("$arg: unable to stat $scriptsdir/$sf[$i].postinst: $!");
}
$i=0 if $i>=$#sf;
($dr,$de)= @@sf[$i..$i+1];
if (!defined($cyclebreak{$dr,$de})) {
$sincenothing=0; $cyclebreak{$dr,$de}= 1;
&debug("broken cycle $i (@@sf) at $dr -> $de");
return 1;
}
} else {
return if &findbreakcycle($tpp,@@sofar);
}
}
return 0;
}
#*** useful subroutines for actions ***#
sub filesinpackage {
# Returns the list in @@ilist.
# If error, calls &error("$epfx: ...");
local ($epfx, $package) = @@_;
open(LIST,"$listsdir/$package.list") ||
&error("$epfx: database broken for $package - ".
"can't get installed files list: $!");
@@ilist= <LIST>;
eof || &error("$epfx: cannot read $listsdir/$package.list: $!");
close(LIST);
@@ilist= grep((chop,
s|/$||,
m|^/| || s|^|/|,
m/./),
@@ilist);
}
sub installationstatus {
local ($controlstring) = @@_;
local ($lversion,$lpackage,$lstatus,$lrevision,$cmp) = @@_;
local ($cc);
$lversion= $controlstring;
$lversion =~ s/^($packagere)\s*// ||
&internalerr("needed installation status of bogus thing \`$lversion'");
$lpackage= $1;
$lstatus= defined($st_p2s{$lpackage}) ? $st_p2s{$lpackage} : 'not-installed';
if ($lstatus ne 'not-installed') {
if (length($lversion)) {
$lversion =~ s/^\s*\(\s*// && $lversion =~ s/\s*\)\s*$// ||
&internalerr("failed to strip version \`$lversion'");
if ($lversion =~ s/^[><=]//) { $cc= $&; } else { $cc= '='; }
$lrevision = ($lversion =~ s/-([^-]+)$//) ? $1 : '';
$wantedstring= "version $lversion";
$wantedstring .= ", package revision $lrevision" if length($lrevision);
$cmp= &compare_verrevs($st_pk2v{$lpackage,'version'},
$st_pk2v{$lpackage,'package_revision'},
$lversion,
$lrevision);
$installedstring= "version $st_pk2v{$lpackage,'version'}";
$installedstring .=
", package revision $st_pk2v{$lpackage,'package_revision'}"
if length($st_pk2v{$lpackage,'package_revision'});
if ($cc eq '>') {
$rightver= $cmp>=0; $wantedstring.= ' or later';
} elsif ($cc eq '<') {
$rightver= $cmp<=0; $wantedstring.= ' or earlier';
} else {
s/^=//;
$rightver= !$cmp; $wantedstring= "exactly $wantedstring";
}
} else {
$rightver= 1;
$wantedstring= "any version";
$installedstring= $st_pk2v{$lpackage,'version'}.'-'.
$st_pk2v{$lpackage,'package_revision'};
}
} else {
$rightver= -1;
$installedstring= "not installed";
}
return ($lstatus,$rightver,$installedstring,$wantedstring,$lpackage);
}
sub parse_control {
# reads from fh CONTROL
local ($fn) = @@_;
local ($cf,$ln,$l,$k,$v);
defined($cf= &readall('CONTROL')) || &error("read control file $fn: $!");
close(CONTROL);
$p= &parse_control_entry;
if (@@cwarnings) {
&warn("$fn: control file contains oddities: ".join("; ",@@cwarnings))
unless $controlwarn;
}
if (@@cerrors) {
&error("$fn: control file contains errors: ".join("; ",@@cerrors));
}
}
sub run_script_ne {
local ($script,$describe,@@args) = @@_;
local ($extranewlines) = $script =~ m/postinst/;
&debug("running $describe = $script @@args");
if (!stat("$script")) {
return if $! == &ENOENT;
die "couldn't stat $script: $!\n";
}
if (! -x _) {
chmod(0755, "$script") || die "couldn't make $script executable: $!\n";
}
print "\n" if $extranewlines;
&debug("forking now");
defined($rsc= fork) || die "couldn't fork for running $script: $!\n";
if (!$rsc) {
if ($instroot !~ m|^/*$| && !chroot($instroot)) {
print STDERR "$name: failed to chroot to $instroot for $describe: $!\n";
exit(1);
}
exec($script,@@args);
print STDERR "$name: failed to exec $script: $!\n";
exit(1);
}
$!=0; waitpid($rsc,0) == $rsc || die "couldn't wait for $describe: $!\n";
$? && die "$describe failed (".&ecode.")\n";
&debug("script done");
print "\n" if $extranewlines;
}
sub run_script {
return if eval { &run_script_ne; 1; };
$rse= $@@; chop($rse); &error("$package: $rse");
}
sub hash {
local ($file) = @@_; # NB: filename must already have $instroot here
local ($c);
if (open(HF,"<$file")) {
defined($c= open(MDP,"-|")) || &error("fork/pipe for hash: $!");
if (!$c) {
if (!open(STDIN,"<&HF")) {
print STDERR "$name: unable to redirect stdin for hash: $!\n"; exit(1);
}
exec($md5sum); print STDERR "$name: unable to exec $md5sum: $!\n"; exit(1);
}
defined($hash= &readall('MDP')) || &error("unable to read from $md5sum: $!\n");
$!=0; close(MDP); $? && &error("$md5sum returned error (".&ecode.")");
$hash =~ s/\n+$//;
$hash =~ m/^[0-9a-f]{32}$/i || &error("$md5sum returned bogus output \`$hash'");
return $hash;
} elsif ($! == &ENOENT) {
return 'nonexistent';
} else {
&warn("$arg: unable to open conffile $file for hash: $!");
return '-';
}
}
sub files_not_identical {
local ($file1,$file2) = @@_; # NB: filenames must already have $instroot here
if (stat($file1)) {
if (stat($file2)) {
system("cmp","-s",$file1,$file2);
if (&WIFEXITED($?)) {
$es= &WEXITSTATUS($?);
return $es if $es == 0 || $es == 1;
}
&error("cmp $file1 $file2 returned error (".&ecode.")");
} elsif ($! == &ENOENT) {
return 1;
} else {
&error("failed to stat conffile $file2: $!");
}
} elsif ($! == &ENOENT) {
if (stat($file2)) {
return 1;
} elsif ($! == &ENOENT) {
return 0;
} else {
&error("failed to stat conffile $file2: $!");
}
} else {
&error("failed to stat conffile $file1: $!");
}
}
sub copyperm {
local ($from,$to,$name) = @@_;
if (@@statv= stat("$instroot/$from")) {
chown($statv[4],$statv[5],"$instroot/$to") ||
$!==&ENOENT ||
&warn("$package: unable to preserve ownership of $name");
chmod($statv[2],"$instroot/$to") ||
$!==&ENOENT ||
&warn("$package: unable to preserve permissions of $name");
} elsif ($! != &ENOENT) {
&warn("$package: unable to check permissions and ownership of".
" $name in order to preserve them");
}
}
sub conffderef {
local ($file) = @@_;
local ($drf, $warning);
$drf= $file; $warning='';
for (;;) {
if (!lstat("$instroot/$drf")) {
last if $! == &ENOENT; $warning= "unable to lstat: $!"; last;
} elsif (-f _) {
last;
} elsif (-l _) {
if (!defined($lv= readlink("$instroot/$drf"))) {
$warning= "unable to readlink: $!"; last;
}
if ($lv =~ m|^/|) {
$drf= $lv;
} else {
$drf =~ s|/[^/]+$|/$lv|;
}
} else {
$warning= "not a plain file or symlink"; last;
}
}
&debug("conffile $file drf $drf warns \`$warning'");
if ($warning) {
&warn("$arg: possible problem with configuration file $file (= $drf):\n".
" $warning");
return undef;
} else {
return $drf;
}
}
@
1.1
log
@Initial import of dpkg 1.4.0 into local CVS.
@
text
@@
1.1.2.1
log
@Check in NMU series version 1.4.0.22 as found on master et al.
@
text
@@
Reply to: