dpkg (1.1.4); priority=MEDIUM
[dpkg/dpkg.git] / scripts / perl-dpkg.pl
1 #!/usr/bin/perl --
2 #
3 # dpkg: Debian GNU/Linux package maintenance utility
4 #
5 # Copyright (C) 1994 Matt Welsh <mdw@sunsite.unc.edu>
6 # Copyright (C) 1994 Carl Streeter <streeter@cae.wisc.edu>
7 # Copyright (C) 1994 Ian Murdock <imurdock@debian.org>
8 # Copyright (C) 1994 Ian Jackson <iwj10@cus.cam.ac.uk>
9 #
10 #   dpkg is free software; you can redistribute it and/or modify
11 #   it under the terms of the GNU General Public License as
12 #   published by the Free Software Foundation; either version 2,
13 #   or (at your option) any later version.
14 #
15 #   dpkg is distributed in the hope that it will be useful, but
16 #   WITHOUT ANY WARRANTY; without even the implied warranty of
17 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 #   GNU General Public License for more details.
19 #
20 #   You should have received a copy of the GNU General Public
21 #   License along with dpkg; if not, write to the Free Software
22 #   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23 #
24
25 $version= '0.93.15'; # This line modified by Makefile
26
27 sub version {
28     print STDERR <<END;
29 Debian GNU/Linux \`dpkg\' package handling tool version $version.
30 Copyright (C)1994 Matt Welsh, Carl Streeter, Ian Murdock, Ian Jackson.
31 This is free software; see the GNU General Public Licence version 2
32 or later for copying conditions.  There is NO warranty.
33 END
34 }
35
36 sub usage {
37     print STDERR <<END;
38 Usage: dpkg -i|--install <opts> <.deb file name> ... | -a|--auto <dir> ...
39        dpkg --unpack     <opts> <.deb file name> ... | -a|--auto <dir> ...
40        dpkg -A|--avail   <opts> <.deb file name> ... | -a|--auto <dir> ...
41        dpkg --configure  <opts> <package name> ... | -a|--auto
42        dpkg -r|--remove  <opts> <package name> ... | -a|--auto
43        dpkg -l|--list   <status select> [<regexp> ...]
44        dpkg -s|--status <status select> [<package-name> ...]
45        dpkg -S|--search  <glob pattern> ...
46        dpkg -b|--build|-c|--contents|-e|--control|--info|-f|--field|
47             -x|--extract|-X|--vextract ...   (see dpkg-deb --help)
48 Options:  --purge  --control-quiet --control-verbose  --version  --help
49           -R|--root=<directory>  --admindir=<directory>  --instdir=<directory>
50           --no-keep-old-conf  --no-keep-new-conf  -N|--no-also-select
51           --ignore-depends=<package name>,...
52           --conf-(same|diff|all)-(new|old|promptnew|promptold)
53           --force-<thing>,<thing>,...  --no-force-...|--refuse-...
54 Status selections:   --isok-[o][h]        (OK, Hold; alternatives are y, n)
55                      --want-[u][i][d][p]  (Unknown, Install, Deinstall, Purge)
56  --stat-[nupircNO] (Not, Unpacked, Postinst-failed, Installed, Removal-failed,
57                     Config-files, Not/Config-files, Not/Config-files/Installed)
58 Force things:  conflicts, depends, downgrade, depends-version, prermfail,
59                configure-any, hold, extractfail
60     (default is --no-force everything, except --force-downgrade)
61 Use \`$dselect\' for user-friendly package management.
62 END
63 }
64
65 $instroot= '';
66 $controlwarn = 1;
67 $estatus = 0;
68 $filename_pattern = "*.deb";
69 %force= ( 'conflicts',0, 'depends',0, 'depends-version',0, 'downgrade',1,
70           'prermfail',0, 'postrmfail',0, 'hold',0, 'configure-any',0,
71           'extractfail',0 );
72
73 %selectmap_h= ('o','ok', 'h','hold', 'y','ok', 'n','hold');
74 %selectmap_w= ('u', 'unknown', 'i', 'install', 'd', 'deinstall', 'p', 'purge');
75 %selectmap_s= ('n', 'not-installed',
76                'u', 'unpacked',
77                'p', 'postinst-failed',
78                'i', 'installed',
79                'r', 'removal-failed',
80                'c', 'config-files',
81                'n', 'not-installed,config-files',
82                'o', 'not-installed,config-files,installed');
83 %selectthings= ('isok','h', 'want','w', 'stat','s');
84
85 require 'lib.pl'; # This line modified by Makefile
86 $0 =~ m|[^/]+$|; $name = $dpkg;
87 $|=1;
88 umask(022);
89
90 $action= 'none';
91
92 %myabbrevact= ('i','install', 'r','remove', 'A','avail',
93                'S','search', 'l','list', 's','status');
94
95 # $conf...[0] corresponds to `same', 1 to diff
96 $confusenew[0]= 0;  $confprompt[0]= 0;
97 $confusenew[1]= 1;  $confprompt[1]= 1;
98 # Ie, default is to prompt only when hashes differ,
99 # and to use new when hashes differ
100
101 while ($ARGV[0] =~ m/^-/) {
102     $_= shift(@ARGV);
103     $noptsdone++;
104     if (m/^--$/) {
105         $noptsdone--; last;
106     } elsif (m/^--(install|remove|unpack|configure|avail|list|status)$/) {
107         &setaction($1);
108     } elsif (m/^--(build|contents|control|info|field|extract|vextract)$/) {
109         $noptsdone--; &backend($1);
110     } elsif (m/^--ignore-depends=($packagere(,$packagere)*)$/o) {
111         grep($ignore_depends{$_}=1, split(/,/,$1));
112     } elsif (m/^--(force|no-force|refuse)-/) {
113         $fvalue= ($1 eq 'force');
114         for $fv (split(/,/,$')) {
115             defined($force{$fv}) || &badusage("unknown --force option \`$fv'");
116             $force{$fv}= $fvalue;
117         }
118     } elsif (m/^--conf-(same|diff|all)-(new|old|promptnew|promptold)$/) {
119         $new= $2 eq 'new' || $2 eq 'promptnew';
120         $prompt= $2 eq 'promptnew' || $2 eq 'promptold';
121         if ($1 ne 'same') { $confusenew[1]= $new; $confprompt[1]= $prompt; }
122         if ($1 ne 'diff') { $confusenew[0]= $new; $confprompt[0]= $prompt; }
123     } elsif (m/^--(\w+)-(\w+)$/ && defined($selectthings{$1})) {
124         $thisname= $1;
125         $thisthing= $selectthings{$thisname};
126         $_=$2;
127         eval '%thismap= %selectmap_'.$thisthing;
128         while (s/^.//) {
129             if (!defined($thismap{$&})) {
130                 &badusage("unknown status letter $& for status field $thisname");
131             }
132             $thiscodes= $thismap{$&};
133             $selectdo.= "undef \$select_$thisthing;";
134             for $v (split(m/,/, $thiscodes)) {
135                 $selectdo .= "\$select_$thisthing{'$v'}=1;";
136             }
137         }
138     } elsif (m/^--root=/) {
139         $instroot=$'; &setadmindir("$instroot/$orgadmindir");
140     } elsif (m/^--admindir=/) {
141         &setadmindir("$'");
142     } elsif (m/^--instdir=/) {
143         $instroot=$';
144     } elsif (m/^--auto$/) {
145         $auto= 1;
146     } elsif (m/^--purge$/) {
147         $purge= 1;
148     } elsif (m/^--skip-same-version$/) {
149         print STDERR
150             "Warning: dpkg --skip-same-version not implemented, will process\n".
151             " process even packages the same version of which is installed.\n";
152     } elsif (m/^--no-also-select$/) {
153         $noalsoselect= 1;
154     } elsif (m/^--control-verbose$/) {
155         $controlwarn= 1;
156     } elsif (m/^--control-quiet$/) {
157         $controlwarn= 0;
158     } elsif (m/^--no-keep-old-conf$/) {
159         $nokeepold= 1;
160     } elsif (m/^--no-keep-new-conf$/) {
161         $nokeepnew= 1;
162     } elsif (m/^--succinct-prompts$/) {
163         $succinct= 1;
164     } elsif (m/^--debug$/) {
165         $debug= 1;
166     } elsif (m/^--help$/) {
167         &usage; exit(0);
168     } elsif (m/^--version$/) {
169         &version; exit(0);
170     } elsif (m/^--/) {
171         &badusage("unknown option \`$_'");
172     } else {
173         s/^-//; $noptsdone--;
174         while (s/^.//) {
175             $noptsdone++;
176             if (defined($myabbrevact{$&})) {
177                 &setaction($myabbrevact{$&});
178             } elsif (defined($debabbrevact{$&})) {
179                 $noptsdone--; &backend($debabbrevact{$&});
180             } elsif ($& eq 'a') {
181                 $auto= 1;
182             } elsif ($& eq 'D') {
183                 $debug= 1;
184             } elsif ($& eq 'N') {
185                 $noautoselect= 1;
186             } elsif ($& eq 'R') {
187                 s/^=// || &badusage("missing value for -R=<dir> option");
188                 $instroot= $_; &setadmindir("$instroot/$orgadmindir"); $_='';
189             } else {
190                 &badusage("unknown option \`-$&'");
191             }
192         }
193     }
194 }
195
196 $action eq 'none' && &badusage("an action must be specified");
197
198 &debug("arguments parsed");
199
200 #*** list, status or search - the nonactive operations ***#
201
202 if ($action eq 'list' || $action eq 'status') {
203     &database_start;
204     if ($action eq 'list' || !@ARGV) {
205         &selectall(*selectmap_h,*select_h);
206         &selectall(*selectmap_w,*select_w);
207         &selectall(*selectmap_s,*select_s);
208         if (@ARGV) { $select_s{'not-installed'}=0; }
209     }
210     $ecode= 0;
211     if ($action eq 'status') {
212         for ($i=0;$i<=$#keysortorder;$i++) {
213             $keysortorder{$keysortorder[$i]}= sprintf("%6d ",$i);
214 #           &debug("set $i: $keysortorder[$i], sortorder ".
215 #                  "\`$keysortorder{$keysortorder[$i]}'");
216         }
217         @ARGV= &applyselcrit(sort keys %st_p21) unless @ARGV;
218         for $p (@ARGV) {
219             if (!$st_p21{$p}) {
220                 print(STDERR "$name: no information available about package $p\n")
221                     || &bombout("writing to stderr: $!");
222                 $ecode= 1;
223             }
224             print("Package: $p\n",
225                   "Status: $st_p2w{$p} $st_p2h{$p} $st_p2s{$p}\n") || &outerr;
226             for $k (sort { $keysortorder{$a}.$a cmp $keysortorder{$b}.$b; }
227                     keys %all_k21) {
228 #               &debug("field $k, sortorder \`$keysortorder{$k}'");
229                 next unless defined($st_pk2v{$p,$k});
230                 $v= $st_pk2v{$p,$k}; next unless length($v);
231                 if ($k eq 'conffiles' || $k eq 'list') {
232                     $v= sprintf("(%d files, not listed)",
233                                 scalar(grep(m/\S/, split(/\n/,$v))));
234                 }
235                 print("$k: $v\n") || &outerr;
236             }
237             if (defined($av_p21{$p})) {
238                 print("\n\`Available' version of package $p, where different:\n")
239                     || &outerr;
240                 for $k (keys %all_k21) {
241                     next unless defined($av_pk2v{$p,$k});
242                     $v= $st_pk2v{$p,$k}; next unless length($v);
243                     $u= $st_pk2v{$p,$k}; next if $u eq $v;
244                     print("$k: $v\n") || &outerr;
245                 }
246                 print("\n") || &outerr;
247             }
248         }
249     } else { # $action eq 'list'
250         $listhead=0;
251         if (@ARGV) {
252             for $r (@ARGV) {
253                 &listinfo(&applyselcrit(sort grep(m/$r/,keys %st_p21)));
254             }
255         } else {
256             undef $r;
257             &listinfo(&applyselcrit(sort keys %st_p21));
258         }
259     }
260     &database_finish;
261     exit($ecode);
262 }
263
264 sub listinfo {
265     if (!@_) {
266         print(STDERR
267               defined($r) ?
268               "No selected packages found matching regexp \`$r'.\n" :
269               "No packages matched selection criteria.\n") ||
270                   &bombout("writing to stderr: $!");
271         return;
272     }
273
274     if (!$listhead) {
275         print <<END
276 Err?  Name       Version    Rev Description
277 | Status=Not/Unpacked/Postinst-failed/Installed/Removal-failed/Config-files
278 |/ Desired=Unknown/Install/Deinstall/Purge
279 ||/   |          |          |   |
280 +++-============-==========-===-===============================================
281 END
282             || &outerr;
283         $listhead= 1;
284     }
285     for $p (@_) {
286         $des= $st_pk2v{$p,'description'};
287         $des= $` if $des =~ m/\n/;
288         printf("%s%.1s%.1s %-12.12s %-10.10s %-3.3s %-47.47s\n",
289                $st_p2h{$p} eq 'hold' ? 'x' : ' ', $st_p2s{$p}, $st_p2w{$p},
290                $p, $st_pk2v{$p,'version'}, $st_pk2v{$p,'package_revision'},
291                $des);
292     }
293 }
294
295 sub applyselcrit {
296     &debug("sel from @_");
297     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}}:"); }
298     @ascr= grep($select_s{$st_p2s{$_}} &&
299                 $select_w{$st_p2w{$_}} &&
300                 $select_h{$st_p2h{$_}},
301                 @_);
302     &debug("sel gave @ascr");
303     @ascr;
304 }
305
306 sub selectall {
307     local (*map, *sel) = @_;
308     local ($v);
309     for $v (values %map) {
310         next if m/,/;
311         $sel{$v}=1;
312     }
313 }
314
315 if ($action eq 'search') {
316     @ARGV || &badusage("need at least one glob pattern for --$action");
317     &database_start;
318     while (@ARGV) {
319         $orgpat= $_= shift(@ARGV);
320         s/\W/\\$&/g;
321         s|\\\*\\\*|.*|g;
322         s|\\\*|[^/]*|g;
323         s|\\\?|[^/]|g;
324         $pat= $_; $f=0;
325         for $p (sort keys %st_p21) {
326             $s= $st_p2s{$p};
327             next if $s eq 'not-installed' || $s eq 'config-files';
328             &filesinpackage($arg, $package);
329             @ilist= grep(m/^$pat$/,@ilist);
330             next unless @ilist;
331             $f=1;
332             for $_ (@ilist) { print("$p: $_\n") || &outerr; }
333         }
334         if (!$f) {
335             print(STDERR "No packages found containing \`$orgpat'.\n")
336                 || &bombout("writing to stderr: $!");
337             $ecode= 1;
338         }
339     }
340     &database_finish;
341     exit($ecode);
342 }
343
344 #*** lock and read in databases ***#
345
346 &database_start;
347 &debug("databases read");
348
349 #*** derive argument list for --auto ***#
350
351 if ($auto) {
352     if ($action eq 'install' || $action eq 'unpack' || $action eq 'avail') {
353         @ARGV || &badusage("need at least one directory for --$action --auto");
354         pipe(RP,WP) || &bombout("create pipe for \`find': $!");
355         defined($c= fork) || &bombout("fork for \`find': $!");
356         if (!$c) {
357             close(RP); open(STDOUT,">& WP"); close(WP);
358             exec('find',@ARGV,'-name',$filename_pattern,'-type','f','-print0');
359             die "$name: could not exec \`find': $!";
360         }
361         close(WP);
362         $/="\0"; @ARGV= <RP>; $/="\n";
363         eof || &bombout("read filenames from \`find': $!");
364         close(RP);
365         $!=0; waitpid($c,0) eq $c || &bombout("wait for \`find' failed: $!");
366         $? && &bombout("\`find' process returned error code ".&ecode);
367         @ARGV || &bombout("no packages found to $action");
368     } else {
369         @ARGV && &badusage("no package names may be specified with --$action --auto");
370         if ($action eq 'remove') {
371             eval 'sub condition {
372                 $wants eq "deinstall" || $wants eq "purge" || return 0;
373                 $cstatus eq "not-installed" && return 0;
374                 $cstatus eq "config-files" && $wants eq "deinstall" && return 0;
375                 return 1;
376             } 1;' || &internalerr("sub condition: $@");
377         } elsif ($action eq 'configure') {
378             eval 'sub condition {
379                 $wants eq "install" || return 0;
380                 $cstatus eq "unpacked" || $cstatus eq "postinst-failed" || return 0;
381                 return 1;
382             } 1;' || &internalerr("sub condition: $@");
383         } else {
384             &internalerr("unknown auto nonames action $action");
385         }
386         for $p (keys %st_p21) {
387             next if $st_p2h{$p} eq 'hold';
388             $wants= $st_p2w{$p}; $cstatus= $st_p2s{$p};
389             next unless &condition;
390             push(@ARGV,$p);
391         }
392     }
393     &debug("auto: arglist @ARGV");
394 } else {
395     @ARGV || &badusage("need a list of packages or filenames");
396 }
397
398 if ($action eq 'install' || $action eq 'unpack') {
399     grep(s:^[^/.]:./$&:, @ARGV); # Sanitise filenames
400 }
401
402 &debug("action: $action; arglist @ARGV");
403
404 #*** actually do things ***#
405
406 for $arg (@ARGV) {
407     $package= ''; @undo=();
408     &debug("&do_$action($arg)");
409     if (!eval "&do_$action(\$arg); 1;") { &handleerror || last; }
410     &checkpointstatus;
411 }
412 &checkpointstatus;
413
414 if (!$abort) {
415     &debug("&middle_$action($arg)");
416     if (!eval "&middle_$action; 1;") { print STDERR $@; $abort=1; }
417 }
418 &checkpointstatus;
419
420 if (!$abort) {
421     while (@deferred) {
422         $arg= shift(@deferred); $package= ''; @undo=();
423         &debug("&deferred_$action($arg) ($dependtry: $sincenothing)");
424         if (!eval "&deferred_$action(\$arg); 1;") { &handleerror || last; }
425         &checkpointstatus;
426     }
427     &checkpointstatus;
428 }
429
430 if ($errors) {
431     print STDERR "$name: $errors errors occurred.\n";
432     $estatus= 1;
433 }
434
435 &database_finish;
436 &cleanup;
437
438 exit($estatus);
439
440 #*** useful subroutines for main control section ***#
441
442 sub handleerror {
443     print STDERR $@;
444     if (length($package) && defined($st_p21{$package})) {
445         $st_p2h{$package}='hold'; &amended_status($package);
446     }
447     $errors++;
448     if ($errors >20) { print STDERR "$name: too many errors, halting\n"; return 0; }
449     return !$abort;
450 }
451
452 sub checkpointstatus {
453     return unless keys %statusupdated;
454     &amended_status(keys %statusupdated);
455     undef %statusupdated;
456 }
457
458 sub backend {
459     &setaction('');
460     ($noptsdone) && &badusage("action \`$_[0]' must be first argument");
461     &debug("backend --$_[0]");
462     exec($backend, "--$_[0]", @ARGV);
463     &bombout("unable to run $backend: $!");
464 }
465
466 sub setaction {
467     $action eq 'none' || &badusage("conflicting actions \`$action' and \`$1'");
468     $action= $_[0];
469 }
470
471 #*** error handlers for use in actions ***#
472
473 sub warn        { warn "$name - warning: @_\n"; }
474 sub subcriterr  { warn "$name - subcritical error: @_\n"; $estatus=1; }
475 sub error       { &acleanup; die "$name - error: @_\n"; }
476 sub internalerr { &acleanup; die "$name - internal error, please report: @_\n"; }
477 sub fatalerr    { &acleanup; die "$name - fatal error, halting: @_\n"; $abort=1; }
478
479 sub corruptingerr {
480     local ($corruptingerr)= @_;
481     &acleanup;
482     die "$name - horrible error: $corruptingerr;\n".
483         "Package manager data is now out of step with installed system.\n".
484         "Please re-install \`$package' to ensure system consistency!\n".
485         "(Seek assistance from an expert if problems persist.)\n";
486     $abort=1;
487 }
488
489 sub forcibleerr {
490     local ($msg,@forces) = @_;
491     if (@forces= grep($force{$_},@forces)) {
492         &warn("$msg (proceeding due to --force-$forces[0])");
493     } else {
494         &error("$msg (skipping this package)");
495     }
496 }
497
498 sub acleanup {
499     while (@undo) {
500         eval(pop(@undo));
501         $@ && print STDERR "error while cleaning up: $@";
502     }
503 }
504
505 #*** --install ***#
506
507 sub do_install {
508     &do_unpack($arg);
509     $arg= $package;
510     &do_configure($arg);
511 }
512
513 sub deferred_install { &deferred_configure; }
514
515 sub middle_install { &middle_configure }
516
517 #*** --avail ***#
518
519 sub do_avail {
520     unlink($controli);
521     if ($! != &ENOENT) {
522         system('rm','-rf',$controli);
523         unlink($controli);
524         $! == &ENOENT || &fatalerr("unable to get rid of $controli: $!");
525     }
526     &debug("extract control $backend --control $arg $controli");
527     $!=0; system($backend,"--control",$arg,$controli);
528     $? && &error("$arg: could not extract control information (".&ecode.")");
529     open(CONTROL,"$controli/control") ||
530         &error("$arg: corrupt - unable to read control file: $!");
531     &parse_control("$arg");
532     for $k (keys %cf_k2v) {
533         $av_pk2v{$p,$k}= $cf_k2v{$k};
534     }
535     for $k (@nokeepfields) {
536         delete $av_pk2v{$p,$k} unless defined($cf_k2v{$k});
537     }
538     &amended_available($p);
539     $package=$p;
540 }
541
542 sub deferred_avail { }
543 sub middle_avail { }
544
545 #*** --unpack ***#
546
547 sub middle_unpack { }
548
549 sub do_unpack {
550     &do_avail;
551     $cstatus= $st_p2s{$package};
552     if ($st_p2w{$package} ne 'install') {
553         if (!$noalsoselect) {
554             $st_p2w{$package}= 'install'; $statusupdated{$package}= 1;
555             print STDOUT "Selecting previously deselected package $package.\n";
556         } else {
557             print STDOUT "Skipping deselected package $package.\n";
558             return;
559         }
560     }
561     for $tp (split(/,/, $av_pk2v{$package,'conflicts'})) {
562         $tp =~ s/^\s*//; $tp =~ s/\s+$//;
563         ($tps, $rightver, $inst, $want, $tpp)= &installationstatus($tp);
564         unless ($tps eq 'not-installed' || $tps eq 'config-files' || !$rightver) {
565             &forcibleerr("$arg: conflicts with package $tpp ($want),".
566                          " found $inst on system",
567                          'conflicts');
568         }
569     }
570     if ($cstatus eq 'installed') {
571         if (&compare_verrevs($av_pk2v{$package,'version'},
572                              $av_pk2v{$package,'package_revision'},
573                              $st_k2v{'version'},$st_k2v{'package_revision'}) <0) {
574             &forcibleerr("$arg: downgrading installed $package version ".
575                          "$st_k2v{'version'}, ".
576                          "package revision $st_k2v{'package_revision'} ".
577                          "to older version ".
578                          "$av_pk2v{$package,'version'}, ".
579                          "package revision $av_pk2v{$package,'package_revision'}",
580                          'downgrade');
581         }
582     }
583     if (open(CONF,"$controli/conffiles")) {
584         @configf= <CONF>;
585         eof || &error("$arg: unable to read $controli/conffiles: $!");
586         close(CONF);
587         grep((chop, m,^/, || s,^,/,), @configf);
588     } elsif ($! != &ENOENT) {
589         &error("$arg: cannot get config files list: $!");
590     } else {
591         @configf= ();
592     }
593
594     if ($cstatus eq 'installed' || $cstatus eq 'unpacked' ||
595         $cstatus eq 'postinst-failed' || $cstatus eq 'removal-failed') {
596         &filesinpackage($arg,$package);
597         print STDOUT "Preparing to replace $package ...\n";
598     }
599     if ($cstatus eq 'installed') {
600         if (!eval {
601             &run_script_ne("$scriptsdir/$package.prerm", 'old pre-removal script',
602                            'upgrade',
603                            $av_pk2v{$package,'version'}.'-'.
604                            $av_pk2v{$package,'package_revision'});
605             1;
606         }) {
607             &warn("$@... trying script from new package instead.");
608             &run_script("$controli/prerm", 'new prerm script',
609                         'failed-upgrade',
610                         $st_k2v{'version'}.'-'.$st_k2v{'package_revision'});
611         }
612         push(@undo,
613              '$st_p2s{$package}= "postinst-failed"; $statusupdated{$package}=1;
614              &run_script_ne("$scriptsdir/$package.postinst",
615                             "old post-installation script",
616                             "abort-upgrade",
617                             $av_pk2v{$package,"version"}."-".
618                             $av_pk2v{$package,"package_revision"});
619              $st_p2s{$package}= "installed"; $statusupdated{$package}=1;');
620     }
621     @fbackups=();
622     if ($cstatus eq 'installed' || $cstatus eq 'unpacked' ||
623         $cstatus eq 'postinst-failed' || $cstatus eq 'removal-failed') {
624         for ($i=0; $i<=$#ilist; $i++) {
625             next if grep($_ eq $ilist[$i], @configf);
626             $_= $ilist[$i];
627             unless (lstat("$instroot/$_")) {
628                 $! == &ENOENT || &error("old file $_ unstattable: $!");
629                 next;
630             }
631             next if -d _;
632             rename("$instroot/$_","$instroot/$_.dpkg-tmp") ||
633                 &error("couldn't rename old file $_ to $_.dpkg-tmp: $!");
634             push(@undo,
635                  '$_=pop(@fbackups); rename("$instroot/$_.dpkg-tmp","$instroot/$_") ||
636                   die "unable to undo rename of $_ to $_.dpkg-tmp: $!"');
637             push(@fbackups, $_);
638         }
639         if (!eval {
640             &run_script_ne("$scriptsdir/$package.postrm", 'old post-removal script',
641                            'upgrade',
642                            $av_pk2v{$package,'version'}.'-'.
643                            $av_pk2v{$package,'package_revision'});
644             1;
645         }) {
646             &warn("$@... trying script from new package instead.");
647             &run_script("$controli/postrm", 'new post-removal script',
648                         'failed-upgrade',
649                         $st_k2v{'version'}.'-'.$st_k2v{'package_revision'});
650         }
651         push(@undo,
652              '&run_script_ne("$scriptsdir/$package.preinst",
653                              "old pre-installation script",
654                              "abort-upgrade",
655                              $av_pk2v{$package,"version"}.
656                              "-".$av_pk2v{$package,"package_revision"})');
657     }
658     $shortarg= $arg; $shortarg =~ s:.{15,}/:.../:;
659     print STDOUT "Unpacking $arg, containing $package ...\n";
660     &run_script("$controli/preinst", 'pre-installation script',
661                 'upgrade', $st_k2v{'version'}.'-'.$st_k2v{'package_revision'});
662     push(@undo,'&run_script_ne("$controli/postrm", "post-removal script",
663                                "abort-upgrade",
664                                $st_k2v{"version"}."-".$st_k2v{"package_revision"})');
665     if ($cstatus ne 'not-installed') {
666         for $_ (split(/\n/,$st_pk2v{$package,'conffiles'})) {
667             s/^ //; next unless length($_);
668             if (!m/^(\S+) (-|newconffile|nonexistent|[0-9a-f]{32})$/) {
669                 &warn("$arg: ignoring bad stuff in old conffiles field \`$_'");
670                 next;
671             }
672             $oldhash{$1}= $2;
673         }
674     }
675     for $f (@configf) {
676         $drf= &conffderef($f); if (!defined($drf)) { next; }
677         if (lstat("$instroot/$drf.dpkg-tmp")) {
678             $undo=1;
679         } else {
680             $! == &ENOENT || &error("unable to stat backup config file $_.dpkg-tmp: $!");
681             if (lstat("$instroot/$drf")) {
682                 rename("$instroot/$drf","$instroot/$drf.dpkg-tmp") ||
683                     &error("couldn't back up config file $f (= $drf): $!");
684                 $undo=1;
685             } elsif ($! == &ENOENT) {
686                 $undo=0;
687             } else {
688                 &error("unable to stat config file $drf: $!");
689             }
690         }
691         if ($undo) {
692             push(@undo,
693                  '$_=pop(@undof); rename("$instroot/$_.dpkg-tmp","$instroot/$_") ||
694                  die "unable to undo backup of config file $_: $!"');
695             push(@undof, $drf);
696         }
697     }
698
699     open(NL,">$listsdir/$package.list.new") ||
700         &error("$package: cannot create $listsdir/$package.list.new: $!");
701     defined($c= fork) || &error("$package: cannot pipe/fork for $backend --vextract");
702     if (!$c) {
703         if (!open(STDOUT,">&NL")) {
704             print STDERR "$name: cannot redirect stdout: $!\n"; exit(1);
705         }
706         $vexroot= length($instroot) ? $instroot : '/';
707         exec($backend,"--vextract",$arg,$vexroot);
708         print STDERR "$name: cannot exec $backend --vextract $arg $vexroot: $!\n";
709         exit(1);
710     }
711     $!=0; waitpid($c,0) == $c || &error("could not wait for $backend: $!");
712     $? && &forcibleerr("$package: failed to install (".&ecode.")", 'extractfail');
713
714     rename("$listsdir/$package.list.new","$listsdir/$package.list") ||
715         &error("$package: failed to install new $listsdir/$package.list: $!");
716     
717     $newconff='';
718     for $f (@configf) {
719         $h= $oldhash{$f};
720         $h='newconffile' unless length($h);
721         $newconff.= "\n $f $h";
722         &debug("new hash, after unpack, of $f, is $h");
723     }
724
725     for $k (keys %all_k21) {
726         next if $k eq 'binary' || $k eq 'source' || $k eq 'section';
727         $st_pk2v{$package,$k}= $av_pk2v{$package,$k};
728     }
729     $st_pk2v{$package,'conffiles'}= $newconff; $all_k21{'conffiles'}= 1;
730     $st_p2s{$package}= 'unpacked'; $st_p2h{$package}= 'ok'; $st_p21{$package}= 1;
731     $statusupdated{$package}= 1;
732     @undo=(); @undof=();
733
734     for $f (@fbackups) {
735         unlink("$instroot/$f.dpkg-tmp") || $! == &ENOENT ||
736             &subcriterr("$package: unable to delete saved old file $f.dpkg-tmp: $!\n");
737     }
738
739     undef %fordeletion;
740     opendir(PI,"$scriptsdir") ||
741         &corruptingerr("$package: unable to read $scriptsdir directory ($!)");
742     while(defined($_=readdir(PI))) {
743         next unless substr($_,0,length($package)+1) eq $package.'.';
744         $fordeletion{$_}= 1;
745     }
746     closedir(PI);
747     opendir(PI,"$controli") ||
748         &corruptingerr("$package: unable to read $controli".
749                        " new package control information directory ($!)");
750     $fordeletion{"$package.list"}= 0;
751     while(defined($_=readdir(PI))) {
752         next if m/^\.\.?$/ || m/^conffiles$/ || m/^control$/;
753         rename("$controli/$_","$scriptsdir/$package.$_") ||
754             &corruptingerr("$package: unable to install new package control".
755                            " information file $scriptsdir/$package.$_ ($!)");
756         $fordeletion{"$package.$_"}= 0;
757     }
758     closedir(PI);
759     for $_ (keys %fordeletion) {
760         next unless $fordeletion{$_};
761         unlink("$scriptsdir/$_") ||
762             &corruptingerr("$package: unable to remove old package script".
763                            " $scriptsdir/$_ ($!)");
764     }
765 }
766
767 #*** --configure ***#
768
769 sub do_configure {
770     $package=$arg; $cstatus= $st_p2s{$package};
771     if (!defined($st_p21{$package})) { $cstatus= 'not-installed'; }
772     unless ($cstatus eq 'unpacked' || $cstatus eq 'postinst-failed') {
773         if ($cstatus eq 'not-installed') {
774             &error("no package named \`$package' is installed, cannot configure");
775         } else {
776             &error("$package: is currently in state \`$cstatus', cannot configure");
777         }
778     }
779     push(@deferred,$package);
780 }
781
782 sub middle_configure {
783     $sincenothing=0; $dependtry=1;
784 }
785
786 sub deferred_configure {
787     # The algorithm for deciding what to configure first is as follows:
788     # Loop through all packages doing a `try 1' until we've been round
789     # and nothing has been done, then do `try 2' and `try 3' likewise.
790     # Try 1:
791     #  Are all dependencies of this package done ?  If so, do it.
792     #  Are any of the dependencies missing or the wrong version ?
793     #   If so, abort (unless --force-depends, in which case defer)
794     #  Will we need to configure a package we weren't given as an
795     #   argument ?  If so, abort - except if --force-configure-any,
796     #   in which case we add the package to the argument list.
797     #  If none of the above, defer the package.
798     # Try 2:
799     #  Find a cycle and break it (see above).
800     #  Do as for try 1.
801     # Try 3 (only if --force-depends-version).
802     #  Same as for try 2, but don't mind version number in dependencies.
803     # Try 4 (only if --force-depends).
804     #  Do anyway.
805     $package= $arg;
806     if ($sincenothing++ > $#deferred*2+2) {
807         $dependtry++; $sincenothing=0;
808         &internalerr("$package: nothing configured, but try was already 4 !")
809             if $dependtry > 4;
810     }
811     if ($dependtry > 1) { &findbreakcycle($package); }
812     ($ok, @aemsgs) = &dependencies_ok($package,'');
813     if ($ok == 1) {
814         push(@deferred,$package); return;
815     } elsif ($ok == 0) {
816         $sincenothing= 0;
817         &error("$arg: dependency problems - not configuring this package:\n ".
818                join("\n ",@aemsgs));
819     } elsif (@aemsgs) {
820         &warn("$arg: dependency problems, configuring anyway as you request:\n ".
821               join("\n ",@aemsgs));
822     }
823     $sincenothing= 0;
824     print STDOUT "Setting up $package ...\n";
825     if ($st_p2s{$package} eq 'unpacked') {
826         &debug("conffiles updating >$st_pk2v{$package,'conffiles'}<");
827         undef %oldhash; @configf=();
828         for $_ (split(/\n/,$st_pk2v{$package,'conffiles'})) {
829             s/^ //; next unless length($_);
830             if (!m/^(\S+) (-|newconffile|nonexistent|[0-9a-f]{32})$/) {
831                 &warn("$arg: ignoring bad stuff in old conffiles field \`$_'");
832                 next;
833             }
834             $oldhash{$1}= $2; push(@configf,$1);
835             &debug("old hash of $1 is $2");
836         }
837         undef %newhash;
838         for $file (@configf) {
839             $drf= &conffderef($file);
840             if (!defined($drf)) { $newhash{$file}= '-'; next; }
841             $newhash{$file}= &hash("$instroot/$drf");
842             &debug("new hash of $file is $newhash{$file} (old $oldhash{$file})");
843             if ($oldhash{$file} eq 'newconffile') {
844                 $usenew= 1;
845             } else {
846                 if (!&files_not_identical("$instroot/$drf",
847                                           "$instroot/$drf.dpkg-tmp")) {
848                     rename("$instroot/$drf.dpkg-tmp",$drf) || $!==&ENOENT ||
849                         &error("$package: unable to reinstall ".
850                                "existing conffile $drf.dpkg-tmp: $!");
851                     &debug("files identical $file");
852                 } else {
853                     $diff= $newhash{$file} ne $oldhash{$file};
854                     $usenew= $confusenew[$diff];
855                     &debug("the decision - diff $diff;".
856                            " usenew $usenew prompt $confpromt[$diff]");
857                     if ($confprompt[$diff]) {
858                         $symlinked = $drf eq $file ? '' :
859                             $succinct ? " (-> $drf)" :
860                                 " (which is a symlink to $drf)";
861                         for (;;) {
862                             print
863                                 $succinct ? "
864 Package $package, file $file$symlinked, ".($diff ? "CHANGED": "not changed")
865                                   : $diff ? "
866 In package $package, distributed version of configuration
867 file $file$symlinked has changed
868 since the last time it was installed.  You may:
869  * Install the new version and edit it later to reflect your wishes.
870    ". ($nokeepold ?
871   "(Your old version will not be saved.)" :
872   "(Your old version will be saved in $drf.dpkg-old.)") . "
873  * Leave your old version in place, and perhaps check later that
874    you don't want to update it to take account of new features.
875    ". ($nokeepnew ?
876   "(The new version be discarded.)" :
877   "(The new version will be placed in $drf.dpkg-new.)")
878                                           : "
879 Package $package contains the same distributed version of
880 configuration file $file$symlinked
881 as the last time it was installed.  You may:
882  * Install the distributed version, overwriting your changes.
883    ". ($nokeepold ?
884   "(Your changed version will not be saved.)" :
885   "(Your changed version will be saved in $drf.dpkg-old.)") . "
886  * Leave your own version in place.
887    ". ($nokeepnew ?
888   "(The distributed version be discarded.)" :
889   "(The distributed version will be placed in $drf.dpkg-new.)");
890
891                             print "
892 $file: install new version ? (y/n, default=". ($usenew?'y':'n'). ")  ";
893
894                             $!=0; defined($iread= <STDIN>) ||
895                                 &error("$package: prompting, EOF/error on stdin: $!");
896                             $_= $iread; s/^\s*//; s/\s+$//;
897                             ($usenew=0, last) if m/^n(o)?$/i;
898                             ($usenew=1, last) if m/^y(es)?$/i;
899                             last if m/^$/;
900                             print "\nPlease answer \`y' or \`n'.\n";
901                         }
902                     }
903                     &debug("decided, usenew $usenew");
904                     if ($usenew) {
905                         &copyperm("$drf.dpkg-tmp",$drf,$drf);
906                         if ($nokeepold) {
907                             unlink("$instroot/$drf.dpkg-tmp") || $!==&ENOENT ||
908                                 &error("$package: unable to delete old conffile ".
909                                        "$drf.dpkg-tmp: $!");
910                             unlink("$instroot/$drf.dpkg-old") || $!==&ENOENT ||
911                                 &error("$package: unable to delete very old ".
912                                        "conffile $drf.dpkg-old: $!");
913                         } else {
914                             rename("$instroot/$drf.dpkg-tmp","$instroot/$drf.dpkg-old")
915                                 || $!==&ENOENT ||
916                                     &error("$package: unable to back up old conffile ".
917                                            "$drf.dpkg-tmp as $drf.dpkg-old: $!");
918                         }
919                     } else {
920                         unlink("$instroot/$drf.dpkg-new") || $!==&ENOENT ||
921                             &error("$package: unable to delete old new conffile ".
922                                    "$drf.dpkg-new: $!");
923                         if (!$nokeepnew) {
924                             link("$instroot/$drf","$instroot/$drf.dpkg-new")
925                                 || $!==&ENOENT ||
926                                     &error("$package: unable save new conffile ".
927                                            "$drf as $drf.dpkg-new: $!");
928                         }
929                         if (!rename("$instroot/$drf.dpkg-tmp","$instroot/$drf")) {
930                             $!==&ENOENT || &error("$package: unable reinstall old ".
931                                                   "conffile $drf.dpkg-tmp as $drf: $!");
932                             unlink("$instroot/$drf");
933                         }
934                     }
935                 }
936             }
937         }
938         $newconff='';
939         for $f (@configf) {
940             $h= $newhash{$f}; $newconff.= "\n $f $h";
941         }
942         $st_pk2v{$package,'conffiles'}= $newconff; $all_k21{'conffiles'}= 1;
943     }
944     $st_p2s{$package}= 'postinst-failed'; $statusupdated{$package}= 1;
945     &run_script("$scriptsdir/$package.postinst",
946                 'post-installation script', 'configure');
947     $st_p2s{$package}= 'installed';
948     $st_p2h{$package}= 'ok'; $statusupdated{$package}= 1;
949 }
950
951 #*** --remove ***#
952
953 sub do_remove {
954     $package=$arg; $cstatus= $st_p2s{$package};
955     if (!defined($st_p21{$package}) ||
956         $cstatus eq 'not-installed' ||
957         !$purge && $cstatus eq 'config-files') {
958         &error("$package: is not installed, cannot remove");
959     }
960     push(@deferred,$package);
961     if (!$auto) {
962         $ns= $purge ? 'purge' : 'deinstall';
963         if ($st_p2w{$package} ne $ns) {
964             $st_p2w{$package}= $ns; $statusupdated{$package}= 1;
965         }
966     }
967 }
968
969 sub middle_remove {
970     $sincenothing=0; $dependtry=1;
971     for $p (keys %st_p2s) {
972         $cstatus= $st_p2s{$p};
973         next unless $cstatus eq 'installed';
974         for $tp (split(/[\|,]/, $st_pk2v{$p,'depends'})) {
975             $tp =~ s/\s*\(.+\)\s*$//; $tp =~ s/^\s*//; $tp =~ s/\s+$//;
976             $tp =~ m/^$packagere$/o ||
977                 &internalerr("package $p dependency $tp didn't match re");
978             $depended{$tp}.= "$p ";
979         }
980     }
981 }
982
983 sub deferred_remove {
984     $package= $arg;
985     if ($sincenothing++ > $#deferred*2+2) {
986         $dependtry++; $sincenothing=0;
987         &internalerr("$package: nothing configured, but try was already 4 !")
988             if $dependtry > 4;
989     }
990     @raemsgs= (); $rok= 2;
991     &debug("$package may be depended on by any of >$depended{$package}<");
992     for $fp (split(/ /, $depended{$package})) {
993         next if $fp eq '' || $ignore_depends{$tp};
994         $is= $st_p2s{$fp};
995         next if $is eq 'not-installed' || $is eq 'unpacked' ||
996                 $is eq 'removal-failed' || $is eq 'config-files';
997         if ($dependtry > 1) { &findbreakcycle($fp); }
998         ($ok, @aemsgs) = &dependencies_ok($fp,$package);
999         if ($rok != 1) { push(@raemsgs,@aemsgs); }
1000         $rok= $ok if $ok < $rok;
1001     }
1002     if ($rok == 1) {
1003         push(@deferred,$package); return;
1004     } elsif ($rok == 0) {
1005         $sincenothing= 0;
1006         &error("$arg: dependency problems - not removing this package:\n ".
1007                join("\n ",@raemsgs));
1008     } elsif (@raemsgs) {
1009         &warn("$arg: dependency problems, removing anyway as you request:\n ".
1010               join("\n ",@raemsgs));
1011     }
1012     $sincenothing= 0;
1013     &filesinpackage($arg,$package);
1014
1015     undef %hash; @configfr= @configf= ();
1016     for $_ (split(/\n/,$st_pk2v{$package,'conffiles'})) {
1017         s/^ //; next unless length($_);
1018         if (!m/^(\S+) (-|newconffile|nonexistent|[0-9a-f]{32})$/) {
1019             &warn("$arg: ignoring bad stuff in old conffiles field \`$_'");
1020             next;
1021         }
1022         unshift(@configfr,$1); push(@configf,$1);
1023         $hash{$1}= $2;
1024     }
1025     
1026     if ($st_p2s{$package} ne 'config-files') {
1027         print STDOUT "Removing $package ...\n";
1028         &run_script("$scriptsdir/$package.prerm", 'pre-removal script', 'remove');
1029         $st_p2s{$package}= 'removal-failed'; $statusupdated{$package}= 1;
1030         for $file (reverse @ilist) {
1031             next if grep($_ eq $file, @configf);
1032             unlink("$instroot/$file.dpkg-tmp") || $! == &ENOENT ||
1033                 &error("$arg: cannot remove supposed old temp file $file: $!");
1034             next if unlink("$instroot/$file");
1035             next if $! == &ENOENT;
1036             &error("$arg: cannot remove file $file: $!") unless $! == &EISDIR;
1037             next if rmdir("$instroot/$file");
1038             &error("$arg: cannot remove directory $file: $!") unless $! == &ENOTEMPTY;
1039         }
1040         &run_script("$scriptsdir/$package.postrm", 'post-removal script', 'remove');
1041         opendir(DSD,"$scriptsdir") ||
1042             &error("$arg: cannot read directory $scriptsdir: $!");
1043         for $_ (readdir(DSD)) {
1044             next unless m/\.[^.]$/;
1045             next if $& eq '.postrm' || $& eq '.list';
1046             # need postrm for --purge, and list has to go last in case it
1047             # goes wrong
1048             next unless $` eq $package;
1049             unlink("$scriptsdir/$_") ||
1050                 &error("$arg: unable to delete control information $scriptsdir/$_: $!");
1051         }
1052         closedir(DSD);
1053         $st_p2s{$package}= 'config-files';
1054         $statusupdated{$package}= 1;
1055     }
1056     if ($purge) {
1057         print STDOUT "Purging configuration files for $package ...\n";
1058         push(@undo,
1059              '$newconff="";
1060              for $f (@configf) { $newconff.= "\n $f $hash{$f}"; }
1061              $st_pk2v{$package,"conffiles"}= $newconff; $all_k21{"conffiles"}= 1;');
1062         for $file (@configfr) {
1063             $drf= &conffderef($file); if (!defined($drf)) { next; }
1064             unlink("$instroot/$drf") || $! == &ENOENT ||
1065                 &error("$arg: cannot remove old config file $file (= $drf): $!");
1066             $hash{$file}= 'newconffile';
1067             unlink("$instroot/$file") || $! == &ENOENT ||
1068                 &error("$arg: cannot remove old config file $file: $!")
1069                     if $file ne $drf;
1070             for $ext ('.dpkg-tmp', '.dpkg-old', '.dpkg-new', '~', '.bak', '%') {
1071                 unlink("$instroot/$drf$ext") || $! == &ENOENT ||
1072                     &error("$arg: cannot remove old config file $drf$ext: $!");
1073             }
1074             unlink("#$instroot/$drf#") || $! == &ENOENT ||
1075                 &error("$arg: cannot remove old auto-save file #$drf#: $!");
1076             $drf =~ m,^(.*)/, || next; $dir= $1; $base= $';
1077             if (opendir(CFD,"$instroot/$dir")) {
1078                 for $_ (readdir(CFD)) {
1079                     next unless m/\.~\d+~$/;
1080                     next unless $` eq $base;
1081                     unlink("$instroot/$dir/$_") || $! == &ENOENT ||
1082                         &error("$arg: cannot remove old emacs backup file $dir/$_: $!");
1083                 }
1084                 closedir(CFD);
1085                 if (grep($_ eq $dir, @ilist)) {
1086                     rmdir("$instroot/$dir") || $! == &ENOTEMPTY ||
1087                         &error("$arg: cannot remove config file directory $dir: $!");
1088                 }
1089             } elsif ($! != &ENOENT) {
1090                 &error("$arg: cannot read config file dir $dir: $!");
1091             }
1092         }
1093         &run_script("$scriptsdir/$package.postrm", 'post-removal script for purge',
1094                     'purge');
1095         unlink("$scriptsdir/$package.postrm") || $! == &ENOENT ||
1096             &error("$arg: cannot remove old postrm script: $!");
1097         &setnotinstalled;
1098         @undo= ();
1099     } elsif (!@configf && !stat("$scripts/$package.postrm")) {
1100         # If there are no config files and no postrm script then we
1101         # go straight into `purge'.  However, perhaps the stat didn't
1102         # fail with ENOENT ...
1103         $! == &ENOENT || &error("$package: stat failed on postrm script: $!");
1104         $st_p2w{$package}= 'purge';
1105         &setnotinstalled;
1106     }
1107     $st_p2h{$package}= 'ok'; $statusupdated{$package}= 1;
1108 }
1109
1110 sub setnotinstalled {             
1111     unlink("$listsdir/$package.list") ||
1112         &error("$arg: unable to delete old file list: $!");
1113     $st_p2s{$package}= 'not-installed';
1114     for $k (keys %all_k21) { delete $st_pk2v{$package,$k}; }
1115 }
1116
1117 #*** dependency processing - common to --configure and --remove ***#
1118
1119 # The algorithm for deciding what to configure or remove first is as
1120 # follows:
1121 #
1122 # Loop through all packages doing a `try 1' until we've been round and
1123 # nothing has been done, then do `try 2' and `try 3' likewise.
1124 #
1125 # When configuring, in each try we check to see whether all
1126 # dependencies of this package are done.  If so we do it.  If some of
1127 # the dependencies aren't done yet but will be later we defer the
1128 # package, otherwise it is an error.
1129 #
1130 # When removing, in each try we check to see whether there are any
1131 # packages that would have dependencies missing if we removed this
1132 # one.  If not we remove it now.  If some of these packages are
1133 # themselves scheduled for removal we defer the package until they
1134 # have been done.
1135 #
1136 # The criteria for satisfying a dependency vary with the various
1137 # tries.  In try 1 we treat the dependencies as absolute.  In try 2 we
1138 # check break any cycles in the dependency graph involving the package
1139 # we are trying to process before trying to process the package
1140 # normally.  In try 3 (which should only be reached if
1141 # --force-depends-version is set) we ignore version number clauses in
1142 # Depends lines.  In try 4 (only reached if --force-depends is set) we
1143 # say "ok" regardless.
1144 #
1145 # If we are configuring and one of the packages we depend on is
1146 # awaiting configuration but wasn't specified in the argument list we
1147 # will add it to the argument list if --configure-any is specified.
1148 # In this case we note this as having "done something" so that we
1149 # don't needlessly escalate to higher levels of dependency checking
1150 # and breaking.
1151
1152 sub dependencies_ok {
1153     local ($dp, $removingp) = @_;
1154     local ($tpo, $however_t, $ok, $found, @aemsgs, @oemsgs);
1155     local ($tp, $rightver, $inst, $want, $thisf, $matched, $tpp);
1156     $ok= 2; # 2=ok, 1=defer, 0=halt
1157     &debug("checking dependencies of $dp (- $removingp)");
1158     for $tpo (split(/,/, $st_pk2v{$dp,'depends'})) {
1159         $tpo =~ s/^\s*//; $tpo =~ s/\s+$//;
1160         &debug("  checking group $dp -> $tpo");
1161         $matched= 0; @oemsgs=();
1162         $found=0; # 0=none, 1=defer, 2=withwarning, 3=ok
1163         for $tp (split(/\|/, $tpo)) {
1164             $tp =~ s/^\s*//; $tp =~ s/\s+$//;
1165             &debug("  checking possibility $dp -> $tp");
1166             if ($ignore_depends{$tp}) { &debug("ignoring so ok"); $found=3; last; }
1167             if (defined($cyclebreak{$dp,$tp})) { &debug("break cycle"); $found=3; last; }
1168             if ($tp eq $removingp) {
1169                 ($tps, $rightver, $inst, $want, $tpp)= ('removing-now', 1, '','', $tp);
1170                 $matched= 1;
1171             } else {
1172                 ($tps, $rightver, $inst, $want, $tpp)= &installationstatus($tp);
1173                 &debug("installationstatus($tp) -> !$tps!$rightver!$inst!$want!$tps|");
1174             }
1175             if (($tps eq 'installed' || $tps eq 'unpacked' || $tps eq 'postinst-failed')
1176                 && !$rightver) {
1177                 push(@oemsgs,"version of $tpp on system is $inst (wanted $want)");
1178                 if ($force{'depends'}) { $thisf= $dependtry >= 3 ? 2 : 1; }
1179             } elsif ($tps eq 'unpacked' || $tps eq 'postinst-failed') {
1180                 if (grep($_ eq $tpp, @deferred)) {
1181                     $thisf=1;
1182                 } elsif (!length($removingp) && $force{'configure-any'}) {
1183                     &warn("will also configure $tpp");
1184                     push(@deferred,$tpp); $sincenothing=0; $thisf=1;
1185                 } else {
1186                     push(@oemsgs,"package $tpp is not configured yet");
1187                     if ($force{'depends'}) { $thisf= $dependtry >= 4 ? 2 : 1; }
1188                 }
1189             } elsif ($tps eq 'installed') {
1190                 $found=3; last;
1191             } elsif ($tps eq 'removing-now') {
1192                 push(@oemsgs,"$tpp is to be removed");
1193                 if ($force{'depends'}) { $thisf= $dependtry >= 4 ? 2 : 1; }
1194             } else {
1195                 push(@oemsgs,"$tpp ($want) is not installed");
1196                 if ($force{'depends'}) { $thisf= $dependtry >= 4 ? 2 : 1; }
1197             }
1198             &debug(" found $found");
1199             $found=$thisf if $thisf>$found;
1200         }
1201         &debug(" found $found matched $matched");
1202         next if length($removingp) && !$matched;
1203         if (length($removingp) && $tpo !~ m/\|/) {
1204             $however_t= '';
1205         } elsif (@oemsgs > 1) {
1206             $however_t= "\n  However, ". join(",\n   ", @oemsgs[0..($#oemsgs-1)]).
1207                       " and\n   ". $oemsgs[$#oemsgs]. ".";
1208         } else {
1209             $however_t= "\n  However, @oemsgs.";
1210         }
1211         if ($found == 0) {
1212             push(@aemsgs, "$dp depends on $tpo.$however_t");
1213             $ok=0;
1214         } elsif ($found == 1) {
1215             $ok=1 if $ok>1;
1216         } elsif ($found == 2) {
1217             push(@aemsgs, "$dp depends on $tpo.$however_t");
1218         } elsif ($found != 3) {
1219             &internalerr("found value in deferred_configure $found not known");
1220         }
1221     }
1222     &debug("ok $ok msgs >>@aemsgs<<");
1223     return ($ok, @aemsgs);
1224 }
1225
1226 sub findbreakcycle {
1227     # Cycle breaking works recursively down the package dependency
1228     # tree.  @sofar is the list of packages we've descended down
1229     # already - if we encounter any of its packages again in a
1230     # dependency we have found a cycle.
1231     #
1232     # Cycles are preferentially broken by ignoring a dependency from
1233     # a package which doesn't have a postinst script.  If there isn't
1234     # such a dependency in the cycle we break at the `start' of the
1235     # cycle from the point of view of our package.
1236     #
1237     local ($package,@sofar) = @_;
1238     local ($tp,$tpp,$tps,$rightver,$inst,$want,$i,$dr,$de,@sf);
1239     &debug("findbreakcycle($package; @sofar)");
1240     push(@sofar,$package);
1241     for $tp (split(/[,|]/, $st_pk2v{$package,'depends'})) {
1242         $tp =~ s/^\s*//; $tp =~ s/\s+$//;
1243         ($tps, $rightver, $inst, $want, $tpp)= &installationstatus($tp);
1244         next unless $tps eq 'config-files' || $tps eq 'unpacked';
1245         next if $cyclebreak{$package,$tpp};
1246         if (grep($_ eq $tpp, @sofar)) {
1247             &debug("found cycle $package, $tpp (@sofar)");
1248             @sf= (@sofar,$tpp);
1249             for ($i=0;
1250                  $i<$#sf;
1251                  $i++) {
1252                 next if stat("$scriptsdir/$sf[$i].postinst");
1253                 last if $! == &ENOENT;
1254                 &error("$arg: unable to stat $scriptsdir/$sf[$i].postinst: $!");
1255             }
1256             $i=0 if $i>=$#sf;
1257             ($dr,$de)= @sf[$i..$i+1];
1258             if (!defined($cyclebreak{$dr,$de})) {
1259                 $sincenothing=0; $cyclebreak{$dr,$de}= 1;
1260                 &debug("broken cycle $i (@sf) at $dr -> $de");
1261                 return 1;
1262             }
1263         } else {
1264             return if &findbreakcycle($tpp,@sofar);
1265         }
1266     }
1267     return 0;
1268 }
1269
1270 #*** useful subroutines for actions ***#
1271
1272 sub filesinpackage {
1273     # Returns the list in @ilist.
1274     # If error, calls &error("$epfx: ...");
1275     local ($epfx, $package) = @_;
1276     open(LIST,"$listsdir/$package.list") ||
1277         &error("$epfx: database broken for $package - ".
1278                "can't get installed files list: $!");
1279     @ilist= <LIST>;
1280     eof || &error("$epfx: cannot read $listsdir/$package.list: $!");
1281     close(LIST);
1282     @ilist= grep((chop,
1283                   s|/$||,
1284                   m|^/| || s|^|/|,
1285                   m/./),
1286                  @ilist);
1287 }
1288
1289 sub installationstatus {
1290     local ($controlstring) = @_;
1291     local ($lversion,$lpackage,$lstatus,$lrevision,$cmp) = @_;
1292     local ($cc);
1293     $lversion= $controlstring;
1294     $lversion =~ s/^($packagere)\s*// ||
1295         &internalerr("needed installation status of bogus thing \`$lversion'");
1296     $lpackage= $1;
1297     $lstatus= defined($st_p2s{$lpackage}) ? $st_p2s{$lpackage} : 'not-installed';
1298     if ($lstatus ne 'not-installed') {
1299         if (length($lversion)) {
1300             $lversion =~ s/^\s*\(\s*// && $lversion =~ s/\s*\)\s*$// ||
1301                 &internalerr("failed to strip version \`$lversion'");
1302             if ($lversion =~ s/^[><=]//) { $cc= $&; } else { $cc= '='; }
1303             $lrevision = ($lversion =~ s/-([^-]+)$//) ? $1 : '';
1304             $wantedstring= "version $lversion";
1305             $wantedstring .= ", package revision $lrevision" if length($lrevision);
1306             $cmp= &compare_verrevs($st_pk2v{$lpackage,'version'},
1307                                    $st_pk2v{$lpackage,'package_revision'},
1308                                    $lversion,
1309                                    $lrevision);
1310             $installedstring= "version $st_pk2v{$lpackage,'version'}";
1311             $installedstring .=
1312                 ", package revision $st_pk2v{$lpackage,'package_revision'}"
1313                     if length($st_pk2v{$lpackage,'package_revision'});
1314             if ($cc eq '>') {
1315                 $rightver= $cmp>=0; $wantedstring.= ' or later';
1316             } elsif ($cc eq '<') {
1317                 $rightver= $cmp<=0; $wantedstring.= ' or earlier';
1318             } else {
1319                 s/^=//;
1320                 $rightver= !$cmp; $wantedstring= "exactly $wantedstring";
1321             }
1322         } else {
1323             $rightver= 1;
1324             $wantedstring= "any version";
1325             $installedstring= $st_pk2v{$lpackage,'version'}.'-'.
1326                               $st_pk2v{$lpackage,'package_revision'};
1327         }
1328     } else {
1329         $rightver= -1;
1330         $installedstring= "not installed";
1331     }
1332     return ($lstatus,$rightver,$installedstring,$wantedstring,$lpackage);
1333 }
1334
1335 sub parse_control {
1336     # reads from fh CONTROL
1337     local ($fn) = @_;
1338     local ($cf,$ln,$l,$k,$v);
1339     defined($cf= &readall('CONTROL')) || &error("read control file $fn: $!");
1340     close(CONTROL);
1341     $p= &parse_control_entry;
1342     if (@cwarnings) {
1343         &warn("$fn: control file contains oddities: ".join("; ",@cwarnings))
1344             unless $controlwarn;
1345     }
1346     if (@cerrors) {
1347         &error("$fn: control file contains errors: ".join("; ",@cerrors));
1348     }
1349 }
1350
1351 sub run_script_ne {
1352     local ($script,$describe,@args) = @_;
1353     local ($extranewlines) = $script =~ m/postinst/;
1354     &debug("running $describe = $script @args");
1355     if (!stat("$script")) {
1356         return if $! == &ENOENT;
1357         die "couldn't stat $script: $!\n";
1358     }
1359     if (! -x _) {
1360         chmod(0755, "$script") || die "couldn't make $script executable: $!\n";
1361     }
1362     print "\n" if $extranewlines;
1363     &debug("forking now");
1364     defined($rsc= fork) || die "couldn't fork for running $script: $!\n";
1365     if (!$rsc) {
1366         if ($instroot !~ m|^/*$| && !chroot($instroot)) {
1367             print STDERR "$name: failed to chroot to $instroot for $describe: $!\n";
1368             exit(1);
1369         }
1370         exec($script,@args);
1371         print STDERR "$name: failed to exec $script: $!\n";
1372         exit(1);
1373     }
1374     $!=0; waitpid($rsc,0) == $rsc || die "couldn't wait for $describe: $!\n";
1375     $? && die "$describe failed (".&ecode.")\n";
1376     &debug("script done");
1377     print "\n" if $extranewlines;
1378 }
1379
1380 sub run_script {
1381     return if eval { &run_script_ne; 1; };
1382     $rse= $@; chop($rse); &error("$package: $rse");
1383 }
1384
1385 sub hash {
1386     local ($file) = @_; # NB: filename must already have $instroot here
1387     local ($c);
1388     if (open(HF,"<$file")) {
1389         defined($c= open(MDP,"-|")) || &error("fork/pipe for hash: $!");
1390         if (!$c) {
1391             if (!open(STDIN,"<&HF")) {
1392                 print STDERR "$name: unable to redirect stdin for hash: $!\n"; exit(1);
1393             }
1394             exec($md5sum); print STDERR "$name: unable to exec $md5sum: $!\n"; exit(1);
1395         }
1396         defined($hash= &readall('MDP')) || &error("unable to read from $md5sum: $!\n");
1397         $!=0; close(MDP); $? && &error("$md5sum returned error (".&ecode.")");
1398         $hash =~ s/\n+$//;
1399         $hash =~ m/^[0-9a-f]{32}$/i || &error("$md5sum returned bogus output \`$hash'");
1400         return $hash;
1401     } elsif ($! == &ENOENT) {
1402         return 'nonexistent';
1403     } else {
1404         &warn("$arg: unable to open conffile $file for hash: $!");
1405         return '-';
1406     }
1407 }
1408
1409 sub files_not_identical {
1410     local ($file1,$file2) = @_; # NB: filenames must already have $instroot here
1411     if (stat($file1)) {
1412         if (stat($file2)) {
1413             system("cmp","-s",$file1,$file2);
1414             if (&WIFEXITED($?)) {
1415                 $es= &WEXITSTATUS($?);
1416                 return $es if $es == 0 || $es == 1;
1417             }
1418             &error("cmp $file1 $file2 returned error (".&ecode.")");
1419         } elsif ($! == &ENOENT) {
1420             return 1;
1421         } else {
1422             &error("failed to stat conffile $file2: $!");
1423         }
1424     } elsif ($! == &ENOENT) {
1425         if (stat($file2)) {
1426             return 1;
1427         } elsif ($! == &ENOENT) {
1428             return 0;
1429         } else {
1430             &error("failed to stat conffile $file2: $!");
1431         }
1432     } else {
1433         &error("failed to stat conffile $file1: $!");
1434     }
1435 }
1436
1437 sub copyperm {
1438     local ($from,$to,$name) = @_;
1439     if (@statv= stat("$instroot/$from")) {
1440         chown($statv[4],$statv[5],"$instroot/$to") ||
1441             $!==&ENOENT ||
1442                 &warn("$package: unable to preserve ownership of $name");
1443         chmod($statv[2],"$instroot/$to") ||
1444             $!==&ENOENT ||
1445                 &warn("$package: unable to preserve permissions of $name");
1446     } elsif ($! != &ENOENT) {
1447         &warn("$package: unable to check permissions and ownership of".
1448               " $name in order to preserve them");
1449     }
1450 }
1451
1452 sub conffderef {
1453     local ($file) = @_;
1454     local ($drf, $warning);
1455     $drf= $file; $warning='';
1456     for (;;) {
1457         if (!lstat("$instroot/$drf")) {
1458             last if $! == &ENOENT; $warning= "unable to lstat: $!"; last;
1459         } elsif (-f _) {
1460             last;
1461         } elsif (-l _) {
1462             if (!defined($lv= readlink("$instroot/$drf"))) {
1463                 $warning= "unable to readlink: $!"; last;
1464             }
1465             if ($lv =~ m|^/|) {
1466                 $drf= $lv;
1467             } else {
1468                 $drf =~ s|/[^/]+$|/$lv|;
1469             }
1470         } else {
1471             $warning= "not a plain file or symlink"; last;
1472         }
1473     }
1474     &debug("conffile $file drf $drf warns \`$warning'");
1475     if ($warning) {
1476         &warn("$arg: possible problem with configuration file $file (= $drf):\n".
1477               " $warning");
1478         return undef;
1479     } else {
1480         return $drf;
1481     }
1482 }