| Current File : //usr/sbin/dpkg-reconfigure |
#!/usr/bin/perl -w
# This file was preprocessed, do not edit!
if (exists $ENV{DEBCONF_USE_CDEBCONF} and $ENV{DEBCONF_USE_CDEBCONF} ne '') {
exec "/usr/lib/cdebconf/dpkg-reconfigure", @ARGV;
}
use strict;
use Cwd;
use Debconf::Db;
use Debconf::Gettext;
use Debconf::Template;
use Debconf::Config;
use Debconf::AutoSelect qw(:all);
use Debconf::Log qw(:all);
Debconf::Config->priority('low');
my $unseen_only=0;
my $force=0;
my $default_priority=0;
my $reload=1;
Debconf::Config->getopt(
gettext(qq{Usage: dpkg-reconfigure [options] packages
-u, --unseen-only Show only not yet seen questions.
--default-priority Use default priority instead of low.
--force Force reconfiguration of broken packages.
--no-reload Do not reload templates. (Use with caution.)}),
"unseen-only|u" => \$unseen_only,
"default-priority" => \$default_priority,
"force" => \$force,
"reload!" => \$reload,
);
if ($> != 0) {
print STDERR sprintf(gettext("%s must be run as root"), $0)."\n";
exit 1;
}
Debconf::Db->load;
if ($default_priority) {
Debconf::Config->priority(Debconf::Question->get('debconf/priority')->value);
}
if (lc Debconf::Config->frontend eq 'noninteractive' &&
! Debconf::Config->frontend_forced) {
Debconf::Config->frontend('dialog');
}
my $frontend=make_frontend();
unless ($unseen_only) {
Debconf::Config->reshow(1);
}
my @packages=@ARGV;
if (! @packages) {
print STDERR "$0: ".gettext("please specify a package to reconfigure")."\n";
exit 1;
}
$ENV{DEBCONF_RECONFIGURE}=1;
my %initial_triggers=map { $_ => 1 } triggers_pending();
my $original_cwd=getcwd();
foreach my $pkg (@packages) {
$frontend->default_title($pkg);
$frontend->info(undef);
$_=`dpkg --status $pkg`;
my ($version)=m/Version: (.*)\n/;
my ($status)=m/Status: (.*)\n/;
my ($package)=m/Package: (.*)\n/;
my ($arch)=m/Architecture: (.*)\n/;
if (! $force) {
if (! defined $status || $status =~ m/not-installed$/) {
print STDERR "$0: ".sprintf(gettext("%s is not installed"), $pkg)."\n";
exit 1;
}
if ($status !~ m/ ok installed$/) {
print STDERR "$0: ".sprintf(gettext("%s is broken or not fully installed"), $pkg)."\n";
exit 1;
}
}
my @control_paths=`dpkg-query --control-path $pkg`;
map chomp, @control_paths;
my $control_path = sub {
my $file = shift;
my $path = (grep /\.\Q$file\E$/, @control_paths)[0];
chomp($path) if defined $path;
return $path;
};
if ($reload) {
my $templates=$control_path->('templates');
if ($templates and -e $templates) {
Debconf::Template->load($templates, $pkg);
}
}
foreach my $info (['prerm', 'upgrade', $version],
['preinst', 'upgrade', $version],
['config', 'reconfigure', $version],
['postinst', 'configure', $version]) {
my $script=shift @$info;
my $path_script=$control_path->($script);
next unless $path_script and -x $path_script;
my $is_confmodule='';
$ENV{DPKG_MAINTSCRIPT_PACKAGE}=$package;
$ENV{DPKG_MAINTSCRIPT_ARCH}=$arch;
$ENV{DPKG_MAINTSCRIPT_NAME}=$script;
if ($script ne 'config') {
open (IN, "<$path_script");
while (<IN>) {
if (/confmodule/i) {
$is_confmodule=1;
last;
}
}
close IN;
}
chdir('/');
if ($script eq 'config' || $is_confmodule) {
my $confmodule=make_confmodule($path_script, @$info);
$confmodule->owner($pkg);
1 while ($confmodule->communicate);
exit $confmodule->exitcode if $confmodule->exitcode > 0;
}
else {
run_external($path_script, @$info);
}
chdir($original_cwd);
}
}
my @new_triggers;
do {
@new_triggers=();
foreach my $trigpend (triggers_pending()) {
push @new_triggers, $trigpend
if not exists $initial_triggers{$trigpend};
}
if (@new_triggers) {
chdir('/');
run_external("dpkg", "--configure", @new_triggers);
chdir($original_cwd);
}
} while (@new_triggers);
$frontend->shutdown;
Debconf::Db->save;
sub run_external {
Debconf::Db->save;
delete $ENV{DEBIAN_HAS_FRONTEND};
my $ret=system(@_);
if (int($ret / 256) != 0) {
exit int($ret / 256);
}
$ENV{DEBIAN_HAS_FRONTEND}=1;
Debconf::Db->load;
}
sub triggers_pending {
my @ret;
local $_;
open (QUERY, '-|', 'dpkg-query', '-W',
'-f', '${Package} ${binary:Package}\t${Triggers-Pending}\n');
while (<QUERY>) {
chomp;
my ($pkgnames, $triggers) = split /\t/;
if (length $triggers) {
my ($pkg, $binpkg) = split ' ', $pkgnames;
push @ret, (length $binpkg ? $binpkg : $pkg);
}
}
close QUERY;
return @ret;
}