summaryrefslogtreecommitdiffstats
path: root/perl-install
diff options
context:
space:
mode:
authorFrancois Pons <fpons@mandriva.com>2002-07-10 16:25:10 +0000
committerFrancois Pons <fpons@mandriva.com>2002-07-10 16:25:10 +0000
commit1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1 (patch)
tree73c2e8ca7870ef0bb99753a2b1cdf8b16eb7e211 /perl-install
parent52372f1853308aa90b76d4b5cd880c595433fc1d (diff)
downloaddrakx-backup-do-not-use-1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1.tar
drakx-backup-do-not-use-1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1.tar.gz
drakx-backup-do-not-use-1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1.tar.bz2
drakx-backup-do-not-use-1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1.tar.xz
drakx-backup-do-not-use-1a649e4bd1f0a76ec28fcb851b2f8fe2d6d967e1.zip
use perl-URPM instead of rpmtools.
Diffstat (limited to 'perl-install')
-rw-r--r--perl-install/crypto.pm4
-rw-r--r--perl-install/install2.pm4
-rw-r--r--perl-install/install_any.pm9
-rw-r--r--perl-install/install_steps.pm15
-rw-r--r--perl-install/install_steps_gtk.pm94
-rw-r--r--perl-install/install_steps_interactive.pm23
-rw-r--r--perl-install/pkgs.pm1717
-rw-r--r--perl-install/share/list3
8 files changed, 906 insertions, 963 deletions
diff --git a/perl-install/crypto.pm b/perl-install/crypto.pm
index 6a33baff2..d4aabda4e 100644
--- a/perl-install/crypto.pm
+++ b/perl-install/crypto.pm
@@ -108,7 +108,7 @@ sub bestMirror {
sub version {
require pkgs;
my $pkg = pkgs::packageByName($::o->{packages}, 'mandrake-release');
- $pkg && pkgs::packageVersion($pkg) || '8.2'; #- safe but dangerous ;-)
+ $pkg && $pkg->version || '8.2'; #- safe but dangerous ;-)
}
sub dir { $mirrors{$_[0]}[1] . '/' . version() }
@@ -128,8 +128,6 @@ sub getFile {
$$retr ||= $ftp->retr($file);
}
-sub getDepslist { getFile("depslist-crypto", $_[0]) or die "unable to get depslist-crypto" }
-
sub getPackages {
my ($prefix, $packages, $mirror) = @_;
diff --git a/perl-install/install2.pm b/perl-install/install2.pm
index 0b5c58b92..c5f3cddde 100644
--- a/perl-install/install2.pm
+++ b/perl-install/install2.pm
@@ -207,7 +207,7 @@ sub choosePackages {
log::l("compssUsersChoice's: ", join(" ", grep { $o->{compssUsersChoice}{$_} } keys %{$o->{compssUsersChoice}}));
#- check pre-condition where base backage has to be selected.
- pkgs::packageFlagSelected(pkgs::packageByName($o->{packages}, 'basesystem')) or die "basesystem package not selected";
+ pkgs::packageByName($o->{packages}, 'basesystem')->flag_selected or die "basesystem package not selected";
#- check if there are package that need installation.
$o->{steps}{installPackages}{done} = 0 if $o->{steps}{installPackages}{done} && pkgs::packagesToInstall($o->{packages}) > 0;
@@ -307,7 +307,7 @@ sub configureX {
modules::write_conf($o->{prefix});
require pkgs;
- installStepsCall($o, $auto, 'configureX', $clicked) if pkgs::packageFlagInstalled(pkgs::packageByName($o->{packages}, 'XFree86')) && !$o->{X}{disabled} || $clicked || $::testing;
+ installStepsCall($o, $auto, 'configureX', $clicked) if pkgs::packageByName($o->{packages}, 'XFree86')->flag_installed && !$o->{X}{disabled} || $clicked || $::testing;
}
#------------------------------------------------------------------------------
sub exitInstall {
diff --git a/perl-install/install_any.pm b/perl-install/install_any.pm
index 78283cf96..4e5bff38b 100644
--- a/perl-install/install_any.pm
+++ b/perl-install/install_any.pm
@@ -165,7 +165,7 @@ sub setup_postinstall_rpms($$) {
pkgs::selectPackage($packages, $p, 0, \%toCopy);
}
- my @toCopy = grep { $_ && pkgs::packageFlagSelected($_) == 0 } map { pkgs::packageByName($packages, $_) } keys %toCopy;
+ my @toCopy = grep { $_ && !$_->flag_selected } map { pkgs::packageByName($packages, $_) } keys %toCopy;
#- extract headers of package, this is necessary for getting
#- the complete filename of each package.
@@ -1116,7 +1116,7 @@ sub is_installed {
my ($do, @l) = @_;
foreach (@l) {
my $p = pkgs::packageByName($do->{o}->{packages}, $_);
- $p && pkgs::packageFlagSelected($p) or return;
+ $p && $p->flag_selected or return;
}
1;
}
@@ -1137,7 +1137,10 @@ sub remove_nodeps {
@l = grep {
my $p = pkgs::packageByName($do->{o}->{packages}, $_);
- pkgs::packageSetFlagSelected($p, 0) if $p;
+ if ($p) {
+ $p->set_flag_requested(0);
+ $p->set_flag_required(0);
+ }
$p;
} @l;
run_program::rooted($do->{o}->{prefix}, 'rpm', '-e', '--nodeps', @l);
diff --git a/perl-install/install_steps.pm b/perl-install/install_steps.pm
index 014e7a70c..cca7d9552 100644
--- a/perl-install/install_steps.pm
+++ b/perl-install/install_steps.pm
@@ -362,8 +362,8 @@ sub installPackages($$) { #- complete REWORK, TODO and TOCHECK!
$o->{toSave} = [];
#- hack for compat-glibc to upgrade properly :-(
- if (pkgs::packageFlagSelected(pkgs::packageByName($packages, 'compat-glibc')) &&
- !pkgs::packageFlagInstalled(pkgs::packageByName($packages, 'compat-glibc'))) {
+ if (pkgs::packageByName($packages, 'compat-glibc')->flag_selected &&
+ !pkgs::packageByName($packages, 'compat-glibc')->flag_installed) {
rename "$o->{prefix}/usr/i386-glibc20-linux", "$o->{prefix}/usr/i386-glibc20-linux.mdkgisave";
}
}
@@ -373,7 +373,7 @@ sub installPackages($$) { #- complete REWORK, TODO and TOCHECK!
my $time = time;
$ENV{DURING_INSTALL} = 1;
- pkgs::install($o->{prefix}, $o->{isUpgrade}, \@toInstall, $packages->{depslist}, $packages->{mediums});
+ pkgs::install($o->{prefix}, $o->{isUpgrade}, \@toInstall, $packages);
delete $ENV{DURING_INSTALL};
run_program::rooted_or_die($o->{prefix}, 'ldconfig') unless $::g_auto_install;
log::l("Install took: ", formatTimeRaw(time - $time));
@@ -406,7 +406,7 @@ Consoles 1,3,4,7 may also contain interesting information";
if (do {
my $p = pkgs::packageByName($o->{packages}, 'devfsd');
- $p && pkgs::packageFlagInstalled($p)
+ $p && $p->flag_installed
}) {
require bootloader;
bootloader::may_append($o->{bootloader}, devfs => 'mount');
@@ -489,8 +489,7 @@ GridHeight=70
#- and rename saved files to .mdkgiorig.
if ($o->{isUpgrade}) {
my $pkg = pkgs::packageByName($o->{packages}, 'rpm');
- $pkg && pkgs::packageSelectedOrInstalled($pkg) && pkgs::versionCompare(pkgs::packageVersion($pkg), '4.0') >= 0 and
- pkgs::clean_old_rpm_db($o->{prefix});
+ $pkg && ($pkg->flag_selected || $pkg->flag_installed) && $pkg->compare(">= 4.0") and pkgs::clean_old_rpm_db($o->{prefix});
log::l("moving previous desktop files that have been updated to Trash of each user");
install_any::kdemove_desktop_file($o->{prefix});
@@ -536,7 +535,7 @@ sub install_urpmi {
my ($o) = @_;
my $pkg = pkgs::packageByName($o->{packages}, 'urpmi');
- if ($pkg && pkgs::packageSelectedOrInstalled($pkg)) {
+ if ($pkg && ($pkg->flag_selected || $pkg->flag_installed)) {
install_any::install_urpmi($o->{prefix},
$::oem ? 'cdrom' : $o->{method}, #- HACK
$o->{packages}{mediums});
@@ -833,7 +832,7 @@ sub setupBootloaderBefore {
#- propose the default fb mode for kernel fb, if aurora or bootsplash is installed.
my $need_fb = grep {
my $p = pkgs::packageByName($o->{packages}, $_);
- $p && pkgs::packageFlagInstalled($p);
+ $p && $p->flag_installed;
} 'Aurora', 'bootsplash';
bootloader::suggest($o->{prefix}, $o->{bootloader}, $o->{all_hds}{hds}, $o->{fstab},
($force_vga || $vga && $need_fb) && $o->{vga}, $o->{meta_class} ne 'server');
diff --git a/perl-install/install_steps_gtk.pm b/perl-install/install_steps_gtk.pm
index 5bebf5c84..36c7139ac 100644
--- a/perl-install/install_steps_gtk.pm
+++ b/perl-install/install_steps_gtk.pm
@@ -348,17 +348,16 @@ sub choosePackagesTree {
node_state => sub {
my $p = pkgs::packageByName($packages,$_[0]) or return;
pkgs::packageMedium($packages, $p)->{selected} or return;
- pkgs::packageFlagBase($p) and return 'base';
- pkgs::packageFlagInstalled($p) and return 'installed';
- pkgs::packageFlagSelected($p) and return 'selected';
+ $p->flag_base and return 'base';
+ $p->flag_installed and return 'installed';
+ $p->flag_selected and return 'selected';
return 'unselected';
},
build_tree => sub {
my ($add_node, $flat) = @_;
if ($flat) {
- foreach (sort keys %{$packages->{names}}) {
- !$limit_to_medium ||
- pkgs::packageMedium($packages, $packages->{names}{$_}) == $limit_to_medium or next;
+ foreach (sort map { $_->name } grep { !$limit_to_medium || pkgs::packageMedium($packages, $_) }
+ @{$packages->{depslist}}) {
$add_node->($_, undef);
}
} else {
@@ -366,13 +365,13 @@ sub choosePackagesTree {
my (%fl, @firstchoice, @others);
#$fl{$_} = $o->{compssUsersChoice}{$_} foreach @{$o->{compssUsers}{$root}{flags}}; #- FEATURE:improve choce of packages...
$fl{$_} = 1 foreach @{$o->{compssUsers}{$root}{flags}};
- foreach my $p (values %{$packages->{names}}) {
+ foreach my $p (@{$packages->{depslist}}) {
!$limit_to_medium || pkgs::packageMedium($packages, $p) == $limit_to_medium or next;
- my ($rate, @flags) = pkgs::packageRateRFlags($p);
- next if !($rate && grep { grep { !/^!/ && $fl{$_} } split('\|\|') } @flags);
- $rate >= 3 ?
- push(@firstchoice, pkgs::packageName($p)) :
- push(@others, pkgs::packageName($p));
+ my @flags = $p->rflags;
+ next if !($p->rate && grep { grep { !/^!/ && $fl{$_} } split('\|\|') } @flags);
+ $p->rate >= 3 ?
+ push(@firstchoice, $p->name) :
+ push(@others, $p->name);
}
my $root2 = join('|', map { translate($_) } split('\|', $root));
$add_node->($_, $root2 ) foreach sort @firstchoice;
@@ -383,35 +382,33 @@ sub choosePackagesTree {
get_info => sub {
my $p = pkgs::packageByName($packages, $_[0]) or return '';
pkgs::extractHeaders($o->{prefix}, [$p], $packages->{mediums});
- pkgs::packageHeader($p) or die;
- my $imp = translate($pkgs::compssListDesc{pkgs::packageFlagBase($p) ?
- 5 : pkgs::packageRate($p)});
+ my $imp = translate($pkgs::compssListDesc{$p->flag_base ? 5 : $p->rate});
my $info = $@ ? _("Bad package") :
- (_("Name: %s\n", pkgs::packageName($p)) .
- _("Version: %s\n", pkgs::packageVersion($p) . '-' . pkgs::packageRelease($p)) .
- _("Size: %d KB\n", pkgs::packageSize($p) / 1024) .
+ (_("Name: %s\n", $p->name) .
+ _("Version: %s\n", $p->version . '-' . $p->release) .
+ _("Size: %d KB\n", $p->size / 1024) .
($imp && _("Importance: %s\n", $imp)) . "\n" .
- formatLines(c::headerGetEntry(pkgs::packageHeader($p), 'description')));
- pkgs::packageFreeHeader($p);
+ formatLines($p->description));
return $info;
},
toggle_nodes => sub {
my $set_state = shift @_;
my @n = map { pkgs::packageByName($packages, $_) } @_;
my %l;
- my $isSelection = !pkgs::packageFlagSelected($n[0]);
+ my $isSelection = !$n[0]->flag_selected;
foreach (@n) {
- pkgs::togglePackageSelection($packages, $_, my $l = {});
- @l{grep {$l->{$_}} keys %$l} = ();
+ #pkgs::togglePackageSelection($packages, $_, my $l = {});
+ #@l{grep {$l->{$_}} keys %$l} = ();
+ pkgs::togglePackageSelection($packages, $_, \%l);
}
- if (my @l = keys %l) {
+ if (my @l = map { $packages->{depslist}[$_]->name } keys %l) {
#- check for size before trying to select.
my $size = pkgs::selectedSize($packages);
foreach (@l) {
- my $p = $packages->{names}{$_};
- pkgs::packageFlagSelected($p) or $size += pkgs::packageSize($p);
+ my $p = pkgs::packageByName($packages, $_);
+ $p->flag_selected or $size += $p->size;
}
if (pkgs::correctSize($size / sqr(1024)) > $available / sqr(1024)) {
return $o->ask_warn('', _("You can't select this package as there is not enough space left to install it"));
@@ -429,29 +426,27 @@ sub choosePackagesTree {
}
foreach (@l) {
my $p = pkgs::packageByName($packages, $_);
- $set_state->($_, pkgs::packageFlagSelected($p) ? 'selected' : 'unselected');
+ $set_state->($_, $p->flag_selected ? 'selected' : 'unselected');
}
} else {
$o->ask_warn('', _("You can't select/unselect this package"));
}
},
grep_allowed_to_toggle => sub {
- grep { $_ ne _("Other") && !pkgs::packageFlagBase(pkgs::packageByName($packages, $_)) } @_;
+ grep { $_ ne _("Other") && !pkgs::packageByName($packages, $_)->flag_base } @_;
},
grep_unselected => sub {
- grep { !pkgs::packageFlagSelected(pkgs::packageByName($packages, $_)) } @_;
+ grep { !pkgs::packageByName($packages, $_)->flag_selected } @_;
},
check_interactive_to_toggle => sub {
my $p = pkgs::packageByName($packages, $_[0]) or return;
- if (pkgs::packageFlagBase($p)) {
+ if ($p->flag_base) {
$o->ask_warn('', _("This is a mandatory package, it can't be unselected"));
- } elsif (pkgs::packageFlagInstalled($p)) {
+ } elsif ($p->flag_installed) {
$o->ask_warn('', _("You can't unselect this package. It is already installed"));
- } elsif (pkgs::packageFlagUpgrade($p)) {
+ } elsif ($p->flag_selected && $p->flag_installed) {
if ($::expert) {
- if (pkgs::packageFlagSelected($p)) {
- $o->ask_yesorno('', _("This package must be upgraded.\nAre you sure you want to deselect it?")) or return;
- }
+ $o->ask_yesorno('', _("This package must be upgraded.\nAre you sure you want to deselect it?")) or return;
return 1;
} else {
$o->ask_warn('', _("You can't unselect this package. It must be upgraded"));
@@ -603,36 +598,33 @@ sub installPackages {
my $oldInstallCallback = \&pkgs::installCallback;
local *pkgs::installCallback = sub {
- my $m = shift;
- if ($m =~ /^Starting installation/) {
- $nb = $_[0];
- $total_size = $_[1]; $current_total_size = 0;
+ my ($data, $type, $id, $subtype, $amount, $total) = @_;
+ if ($type eq 'user' && $subtype eq 'install') {
+ #- $amount and $total are used to return number of package and total size.
+ $nb = $amount;
+ $total_size = $total; $current_total_size = 0;
$start_time = time();
$msg->set(_("%d packages", $nb));
$w->flush;
- } elsif ($m =~ /^Starting installing package/) {
+ } elsif ($type eq 'inst' && $subtype eq 'start') {
$progress->update(0);
- my $name = $_[0];
- $msg->set(_("Installing package %s", $name));
+ my $p = $data->{depslist}[$id];
+ $msg->set(_("Installing package %s", $p->name));
$current_total_size += $last_size;
- my $p = pkgs::packageByName($o->{packages}, $name);
- $last_size = c::headerGetEntry(pkgs::packageHeader($p), 'size');
- $text->set((split /\n/, c::headerGetEntry(pkgs::packageHeader($p), 'summary'))[0] || '');
+ $last_size = $p->size;
+ $text->set((split /\n/, $p->summary)[0] || '');
$advertize->(1) if $show_advertising && $total_size > 20_000_000 && time() - $change_time > 20;
$w->flush;
- } elsif ($m =~ /^Progressing installing package/) {
- $progress->update($_[2] ? $_[1] / $_[2] : 0);
+ } elsif ($type eq 'inst' && $subtype eq 'progress') {
+ $progress->update($total ? $amount / $total : 0);
my $dtime = time() - $start_time;
my $ratio =
$total_size == 0 ? 0 :
- pkgs::size2time($current_total_size + $_[1], $total_size) / pkgs::size2time($total_size, $total_size);
+ pkgs::size2time($current_total_size + $amount, $total_size) / pkgs::size2time($total_size, $total_size);
$ratio >= 1 and $ratio = 1;
my $total_time = $ratio ? $dtime / $ratio : time();
-#- my $ratio2 = $total_size == 0 ? 0 : ($current_total_size + $_[1]) / $total_size;
-#- log::l(sprintf("XXXX advance %d %d %s", $current_total_size + $_[1], $dtime, formatTimeRaw($total_time)));
-
$progress_total->update($ratio);
if ($dtime != $last_dtime && $current_total_size > 80_000_000) {
$msg_time_total->set(formatTime(10 * round($total_time / 10) + 10));
diff --git a/perl-install/install_steps_interactive.pm b/perl-install/install_steps_interactive.pm
index fec3d6502..e268f37f7 100644
--- a/perl-install/install_steps_interactive.pm
+++ b/perl-install/install_steps_interactive.pm
@@ -533,10 +533,9 @@ sub choosePackagesTree {
$o->ask_many_from_list('', _("Choose the packages you want to install"),
{
list => [ grep { !$limit_to_medium || pkgs::packageMedium($packages, $_) == $limit_to_medium }
- map { pkgs::packageByName($packages, $_) }
- keys %{$packages->{names}} ],
- value => \&pkgs::packageFlagSelected,
- label => \&pkgs::packageName,
+ @{$packages->{depslist}} ],
+ value => \&URPM::Package::flag_selected,
+ label => \&URPM::Package::name,
sort => 1,
});
}
@@ -766,13 +765,13 @@ sub installPackages {
my $old = \&pkgs::installCallback;
local *pkgs::installCallback = sub {
- my $m = shift;
- if ($m =~ /^Starting installation/) {
- $total = $_[1];
- } elsif ($m =~ /^Starting installing package/) {
- my $name = $_[0];
- $w->set(_("Installing package %s\n%d%%", $name, $total && 100 * $current / $total));
- $current += pkgs::packageSize(pkgs::packageByName($o->{packages}, $name));
+ my ($data, $type, $id, $subtype, $_amount, $_total) = @_;
+ if ($type eq 'user' && $subtype eq 'install') {
+ $total = $_amount;
+ } elsif ($type eq 'inst' && $subtype eq 'start') {
+ my $p = $data->{depslist}[$id];
+ $w->set(_("Installing package %s\n%d%%", $p->name, $total && 100 * $current / $total));
+ $current += $p->size;
} else { unshift @_, $m; goto $old }
};
@@ -991,7 +990,7 @@ sub summary {
my $format_printers = sub {
my $printer = $o->{printer};
if (is_empty_hash_ref($printer->{configured})) {
- pkgs::packageFlagInstalled(pkgs::packageByName($o->{packages}, 'cups')) and return _("Remote CUPS server");
+ pkgs::packageByName($o->{packages}, 'cups')->flag_installed and return _("Remote CUPS server");
return _("No printer");
}
my $entry;
diff --git a/perl-install/pkgs.pm b/perl-install/pkgs.pm
index e5905940a..932256f19 100644
--- a/perl-install/pkgs.pm
+++ b/perl-install/pkgs.pm
@@ -5,6 +5,8 @@ use strict;
use vars qw(*LOG %preferred $limitMinTrans %compssListDesc);
use MDK::Common::System;
+use URPM;
+use URPM::Resolve;
use common;
use install_any;
use run_program;
@@ -16,7 +18,7 @@ use c;
-my @preferred = qw(perl-GTK postfix gcc gcc-cpp gcc-c++ proftpd ghostscript-X vim-minimal kernel db1 db2 ispell-en Bastille-Curses-module nautilus libxpm4);
+my @preferred = qw(perl-GTK postfix gcc gcc-cpp gcc-c++ proftpd ghostscript-X vim-minimal kernel db1 db2 ispell-en Bastille-Curses-module nautilus libxpm4 zlib1 libncurses5 hardrake);
@preferred{@preferred} = ();
#- lower bound on the left ( aka 90 means [90-100[ )
@@ -31,23 +33,23 @@ my @preferred = qw(perl-GTK postfix gcc gcc-cpp gcc-c++ proftpd ghostscript-X vi
#- constant for small transaction.
$limitMinTrans = 8;
-#- constant for package accessor (via table).
-my $FILE = 0;
-my $FLAGS = 1;
-my $SIZE_DEPS = 2;
-my $MEDIUM = 3;
-my $PROVIDES = 4;
-my $VALUES = 5;
-my $HEADER = 6;
-my $INSTALLED_CUMUL_SIZE = 7;
-my $EPOCH = 8;
-
-#- constant for packing flags, see below.
-my $PKGS_SELECTED = 0x00ffffff;
-my $PKGS_FORCE = 0x01000000;
-my $PKGS_INSTALLED = 0x02000000;
-my $PKGS_BASE = 0x04000000;
-my $PKGS_UPGRADE = 0x20000000;
+##- constant for package accessor (via table).
+#my $FILE = 0;
+#my $FLAGS = 1;
+#my $SIZE_DEPS = 2;
+#my $MEDIUM = 3;
+#my $PROVIDES = 4;
+#my $VALUES = 5;
+#my $HEADER = 6;
+#my $INSTALLED_CUMUL_SIZE = 7;
+#my $EPOCH = 8;
+#
+##- constant for packing flags, see below.
+#my $PKGS_SELECTED = 0x00ffffff;
+#my $PKGS_FORCE = 0x01000000;
+#my $PKGS_INSTALLED = 0x02000000;
+#my $PKGS_BASE = 0x04000000;
+#my $PKGS_UPGRADE = 0x20000000;
#- package to ignore, typically in Application CD.
my %ignoreBadPkg = (
@@ -66,62 +68,65 @@ my %ignoreBadPkg = (
#- following flags : selected, force, installed, base, skip.
#- size and deps are grouped to save memory too and make a much
#- simpler and faster depslist reader, this gets (sizeDeps).
-sub packageHeaderFile { $_[0] ? $_[0]->[$FILE]
- : die "invalid package from\n" . backtrace() }
-sub packageName { $_[0] && $_[0]->[$FILE] =~ /^([^:\s]*)-[^:\-\s]+-[^:\-\s]+\.[^:\.\-\s]*(?::.*)?/ ? $1
- : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() }
-sub packageVersion { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-([^:\-\s]+)-[^:\-\s]+\.[^:\.\-\s]*(?::.*)?/ ? $1
- : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() }
-sub packageRelease { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-[^:\-\s]+-([^:\-\s]+)\.[^:\.\-\s]*(?::.*)?/ ? $1
- : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() }
-sub packageArch { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-[^:\-\s]+-[^:\-\s]+\.([^:\.\-\s]*)(?::.*)?/ ? $1
- : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() }
-sub packageFile { $_[0] && $_[0]->[$FILE] =~ /^([^:\s]*-[^:\-\s]+-[^:\-\s]+\.[^:\.\-\s]*)(?::(.*))?/ ? ($2 || $1) . ".rpm"
- : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() }
-sub packageEpoch { $_[0] && $_[0]->[$EPOCH] || 0 }
-
-sub packageSize { to_int($_[0] && ($_[0]->[$SIZE_DEPS] - ($_[0]->[$INSTALLED_CUMUL_SIZE] || 0))) }
-sub packageDepsId { split ' ', ($_[0] && ($_[0]->[$SIZE_DEPS] =~ /^\d*\s*(.*)/)[0]) }
-
-sub packageFlagSelected { $_[0] && $_[0]->[$FLAGS] & $PKGS_SELECTED }
-sub packageFlagForce { $_[0] && $_[0]->[$FLAGS] & $PKGS_FORCE }
-sub packageFlagInstalled { $_[0] && $_[0]->[$FLAGS] & $PKGS_INSTALLED }
-sub packageFlagBase { $_[0] && $_[0]->[$FLAGS] & $PKGS_BASE }
-sub packageFlagUpgrade { $_[0] && $_[0]->[$FLAGS] & $PKGS_UPGRADE }
-
-sub packageSetFlagSelected { $_[0]->[$FLAGS] &= ~$PKGS_SELECTED; $_[0]->[$FLAGS] |= $_[1] & $PKGS_SELECTED; }
-
-sub packageSetFlagForce { $_[0] or die "invalid package from\n" . backtrace();
- $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_FORCE) : ($_[0]->[$FLAGS] &= ~$PKGS_FORCE); }
-sub packageSetFlagInstalled { $_[0] or die "invalid package from\n" . backtrace();
- $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_INSTALLED) : ($_[0]->[$FLAGS] &= ~$PKGS_INSTALLED); }
-sub packageSetFlagBase { $_[0] or die "invalid package from\n" . backtrace();
- $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_BASE) : ($_[0]->[$FLAGS] &= ~$PKGS_BASE); }
-sub packageSetFlagUpgrade { $_[0] or die "invalid package from\n" . backtrace();
- $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_UPGRADE) : ($_[0]->[$FLAGS] &= ~$PKGS_UPGRADE); }
-
+#sub packageHeaderFile { $_[0] ? $_[0]->[$FILE]
+# : die "invalid package from\n" . backtrace() }
+#sub packageName { $_[0] && $_[0]->[$FILE] =~ /^([^:\s]*)-[^:\-\s]+-[^:\-\s]+\.[^:\.\-\s]*(?::.*)?/ ? $1
+# : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() }
+#sub packageVersion { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-([^:\-\s]+)-[^:\-\s]+\.[^:\.\-\s]*(?::.*)?/ ? $1
+# : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() }
+#sub packageRelease { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-[^:\-\s]+-([^:\-\s]+)\.[^:\.\-\s]*(?::.*)?/ ? $1
+# : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() }
+#sub packageArch { $_[0] && $_[0]->[$FILE] =~ /^[^:\s]*-[^:\-\s]+-[^:\-\s]+\.([^:\.\-\s]*)(?::.*)?/ ? $1
+# : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() }
+#sub packageFile { $_[0] && $_[0]->[$FILE] =~ /^([^:\s]*-[^:\-\s]+-[^:\-\s]+\.[^:\.\-\s]*)(?::(.*))?/ ? ($2 || $1) . ".rpm"
+# : die "invalid file `" . ($_[0] && $_[0]->[$FILE]) . "'\n" . backtrace() }
+#sub packageEpoch { $_[0] && $_[0]->[$EPOCH] || 0 }
+#
+#sub packageSize { to_int($_[0] && ($_[0]->[$SIZE_DEPS] - ($_[0]->[$INSTALLED_CUMUL_SIZE] || 0))) }
+#sub packageDepsId { split ' ', ($_[0] && ($_[0]->[$SIZE_DEPS] =~ /^\d*\s*(.*)/)[0]) }
+#
+#sub packageFlagSelected { $_[0] && $_[0]->[$FLAGS] & $PKGS_SELECTED }
+#sub packageFlagForce { $_[0] && $_[0]->[$FLAGS] & $PKGS_FORCE }
+#sub packageFlagInstalled { $_[0] && $_[0]->[$FLAGS] & $PKGS_INSTALLED }
+#sub packageFlagBase { $_[0] && $_[0]->[$FLAGS] & $PKGS_BASE }
+#sub packageFlagUpgrade { $_[0] && $_[0]->[$FLAGS] & $PKGS_UPGRADE }
+#
+#sub packageSetFlagSelected { $_[0]->[$FLAGS] &= ~$PKGS_SELECTED; $_[0]->[$FLAGS] |= $_[1] & $PKGS_SELECTED; }
+#
+#sub packageSetFlagForce { $_[0] or die "invalid package from\n" . backtrace();
+# $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_FORCE) : ($_[0]->[$FLAGS] &= ~$PKGS_FORCE); }
+#sub packageSetFlagInstalled { $_[0] or die "invalid package from\n" . backtrace();
+# $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_INSTALLED) : ($_[0]->[$FLAGS] &= ~$PKGS_INSTALLED); }
+#sub packageSetFlagBase { $_[0] or die "invalid package from\n" . backtrace();
+# $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_BASE) : ($_[0]->[$FLAGS] &= ~$PKGS_BASE); }
+#sub packageSetFlagUpgrade { $_[0] or die "invalid package from\n" . backtrace();
+# $_[1] ? ($_[0]->[$FLAGS] |= $PKGS_UPGRADE) : ($_[0]->[$FLAGS] &= ~$PKGS_UPGRADE); }
+#
sub packageMedium { my ($packages, $p) = @_; $p or die "invalid package from\n" . backtrace();
- $packages->{mediums}{$p->[$MEDIUM]} }
-
-sub packageProvides { $_[1] or die "invalid package from\n" . backtrace();
- map { $_[0]->{depslist}[$_] || die "unkown package id $_" } unpack "s*", $_[1]->[$PROVIDES] }
-
-sub packageRate { substr($_[0] && $_[0]->[$VALUES], 0, 1) }
-sub packageRateRFlags { my ($rate, @flags) = split "\t", $_[0] && $_[0]->[$VALUES]; ($rate, @flags) }
-sub packageSetRateRFlags { my ($pkg, $rate, @flags) = @_; $pkg or die "invalid package from\n" . backtrace();
- $pkg->[$VALUES] = join("\t", $rate, @flags) }
-
-sub packageHeader { $_[0] && $_[0]->[$HEADER] }
-sub packageFreeHeader { $_[0] && c::headerFree(delete $_[0]->[$HEADER]) }
-
-sub packageSelectedOrInstalled { packageFlagSelected($_[0]) || packageFlagInstalled($_[0]) }
-
-sub packageId {
- my ($packages, $pkg) = @_;
- my $i = 0;
- foreach (@{$packages->{depslist}}) { return $i if $pkg == $packages->{depslist}[$i]; $i++ }
- return;
-}
+ foreach (values %{$packages->{mediums}}) {
+ $p->id >= $_->{start} && $p->id <= $_->{end} and return $_;
+ }
+ return }
+
+#sub packageProvides { $_[1] or die "invalid package from\n" . backtrace();
+# map { $_[0]->{depslist}[$_] || die "unkown package id $_" } unpack "s*", $_[1]->[$PROVIDES] }
+#
+#sub packageRate { substr($_[0] && $_[0]->[$VALUES], 0, 1) }
+#sub packageRateRFlags { my ($rate, @flags) = split "\t", $_[0] && $_[0]->[$VALUES]; ($rate, @flags) }
+#sub packageSetRateRFlags { my ($pkg, $rate, @flags) = @_; $pkg or die "invalid package from\n" . backtrace();
+# $pkg->[$VALUES] = join("\t", $rate, @flags) }
+#
+#sub packageHeader { $_[0] && $_[0]->[$HEADER] }
+#sub packageFreeHeader { $_[0] && c::headerFree(delete $_[0]->[$HEADER]) }
+
+sub packageSelectedOrInstalled { $_[0] && ($_[0]->flag_selected || $_[0]->flag_installed) }
+
+#sub packageId {
+# my ($packages, $pkg) = @_;
+# my $i = 0;
+# foreach (@{$packages->{depslist}}) { return $i if $pkg == $packages->{depslist}[$i]; $i++ }
+# return;
+#}
sub cleanHeaders {
my ($prefix) = @_;
@@ -136,28 +141,29 @@ sub extractHeaders {
cleanHeaders($prefix);
foreach (@$pkgs) {
- push @{$medium2pkgs{$_->[$MEDIUM]} ||= []}, $_;
+ foreach my $medium (values %$media) {
+ $_->id >= $medium->{start} && $_->id <= $medium->{end} or next;
+ push @{$medium2pkgs{$medium->{medium}} ||= []}, $_;
+ }
}
- foreach (values %medium2pkgs) {
- my $medium = $media->{$_->[0][$MEDIUM]}; #- the first one is a valid package pointing to right medium to use.
+ foreach (keys %medium2pkgs) {
+ my $medium = $media->{$_};
eval {
require packdrake;
my $packer = new packdrake("/tmp/$medium->{hdlist}", quiet => 1);
- $packer->extract_archive("$prefix/tmp/headers", map { packageHeaderFile($_) } @$_);
+ $packer->extract_archive("$prefix/tmp/headers", map { $_->header_filename } @{$medium2pkgs{$_}});
};
}
foreach (@$pkgs) {
- my $f = "$prefix/tmp/headers/". packageHeaderFile($_);
- local *H;
- open H, $f or log::l("unable to open header file $f: $!"), next;
- $_->[$HEADER] = c::headerRead(fileno H, 1) or log::l("unable to read header of package ". packageHeaderFile($_));
+ my $f = "$prefix/tmp/headers/". $_->header_filename;
+ $_->update_header($f) or log::l("unable to open header file $f"), next;
}
- @$pkgs = grep { $_->[$HEADER] } @$pkgs;
}
+#- TODO BEFORE TODO
#- size and correction size functions for packages.
my $B = 1.20873;
my $C = 4.98663; #- doesn't take hdlist's into account as getAvailableSpace will do it.
@@ -167,8 +173,8 @@ sub invCorrectSize { ($_[0] - $C) / $B }
sub selectedSize {
my ($packages) = @_;
my $size = 0;
- foreach (values %{$packages->{names}}) {
- packageFlagSelected($_) && !packageFlagInstalled($_) and $size += packageSize($_);
+ foreach (@{$packages->{depslist}}) {
+ $_->flag_selected and $size += $_->size;
}
$size;
}
@@ -195,21 +201,44 @@ sub size2time {
#- a list to search by id.
sub packageByName {
my ($packages, $name) = @_;
- $packages->{names}{$name} or log::l("unknown package `$name'") && undef;
+ #- search package with given name and compatible with current architecture.
+ #- take the best one found (most up-to-date).
+ my @packages;
+ foreach (keys %{$packages->{provides}{$name} || {}}) {
+ my $pkg = $packages->{depslist}[$_];
+ $pkg->is_arch_compat or next;
+ $pkg->name eq $name or next;
+ push @packages, $pkg;
+ }
+ my $best;
+ foreach (@packages) {
+ if ($best && $best != $_) {
+ $_->compare_pkg($best) > 0 and $best = $_;
+ } else {
+ $best = $_;
+ }
+ }
+ $best or log::l("unknown package `$name'") && undef;
}
sub packageById {
my ($packages, $id) = @_;
- my $l = $packages->{depslist}[$id]; #- do not log as id unsupported are still in depslist.
- $l && @$l && $l;
+ my $pkg = $packages->{depslist}[$id]; #- do not log as id unsupported are still in depslist.
+ $pkg->is_arch_compat && $pkg;
}
sub packagesOfMedium {
my ($packages, $medium) = @_;
- grep { $_ && $_->[$MEDIUM] == $medium } @{$packages->{depslist}};
+ $medium->{start} <= $medium->{end} ? @{$packages->{depslist}}[$medium->{start} .. $medium->{end}] : ();
}
sub packagesToInstall {
my ($packages) = @_;
- grep { packageFlagSelected($_) && !packageFlagInstalled($_) &&
- packageMedium($packages, $_)->{selected} } values %{$packages->{names}};
+ my @packages;
+ foreach (values %{$packages->{mediums}}) {
+ $_->{selected} or next;
+ log::l("examining packagesToInstall of medium $_->{descr}");
+ push @packages, grep { $_->flag_selected } packagesOfMedium($packages, $_);
+ }
+ log::l("found " .scalar(@packages). " packages to install");
+ @packages;
}
sub allMediums {
@@ -221,113 +250,85 @@ sub mediumDescr {
$packages->{mediums}{$medium}{descr};
}
-#- selection, unselection of package.
-sub selectPackage { #($$;$$$)
- my ($packages, $pkg, $base, $otherOnly, $check_recursion) = @_;
+sub packageRequest {
+ my ($packages, $pkg) = @_;
- #- check for medium selection, if the medium has not been
- #- selected, the package cannot be selected.
#- check if the same or better version is installed,
#- do not select in such case.
- $pkg && packageMedium($packages, $pkg)->{selected} && !packageFlagInstalled($pkg) or return;
+ $pkg && ($pkg->flag_upgrade || !$pkg->flag_installed) or return;
+
+ #- check for medium selection, if the medium has not been
+ #- selected, the package cannot be selected.
+ foreach (values %{$packages->{mediums}}) {
+ !$_->{selected} && $pkg->id >= $_->{start} && $pkg->id <= $_->{end} and return;
+ }
+
+ return { $pkg->id => 1 };
+}
- #- avoid infinite recursion (mainly against badly generated depslist.ordered).
- $check_recursion ||= {}; exists $check_recursion->{$pkg->[$FILE]} and return; $check_recursion->{$pkg->[$FILE]} = undef;
+sub packageCallbackChoices {
+ my ($urpm, $db, $state, $choices) = @_;
+ my $prefer;
+ foreach (@$choices) {
+ exists $preferred{$_->name} and $prefer = $_;
+ $_->name =~ /kernel-\d/ and $prefer ||= $_;
+ }
+ $prefer || $choices->[0]; #- first one (for instance).
+}
- #- make sure base package are set even if already selected.
- $base and packageSetFlagBase($pkg, 1);
+#- selection, unselection of package.
+sub selectPackage {
+ my ($packages, $pkg, $base, $otherOnly) = @_;
#- select package and dependancies, otherOnly may be a reference
#- to a hash to indicate package that will strictly be selected
#- when value is true, may be selected when value is false (this
#- is only used for unselection, not selection)
- unless (packageFlagSelected($pkg)) {
- foreach (packageDepsId($pkg)) {
- if (/\|/) {
- #- choice deps should be reselected recursively as no
- #- closure on them is computed, this code is exactly the
- #- same as pixel's one.
- my $preferred;
- foreach (split '\|') {
- my $dep = packageById($packages, $_) or next;
- $preferred ||= $dep;
- packageFlagSelected($dep) and $preferred = $dep, last;
- packageName($dep) =~ /kernel-\d/ and $preferred = $dep; #- hard coded preference to simple kernel
- exists $preferred{packageName($dep)} and $preferred = $dep;
- }
- $preferred or die "unable to find a package for choice";
- packageFlagSelected($preferred) or log::l("selecting default package as $preferred->[$FILE]");
- selectPackage($packages, $preferred, $base, $otherOnly, $check_recursion);
- } else {
- #- deps have been closed except for choices, so no need to
- #- recursively apply selection, expand base on it.
- my $dep = packageById($packages, $_);
- $base and packageSetFlagBase($dep, 1);
- $otherOnly and !packageFlagSelected($dep) and $otherOnly->{packageName($dep)} = 1;
- $otherOnly or packageSetFlagSelected($dep, 1+packageFlagSelected($dep));
- }
+ my $state = $packages->{state} ||= {};
+ $state->{selected} = {};
+ $state->{requested} = packageRequest($packages, $pkg) or return;
+ $packages->resolve_requested($packages->{rpmdb}, $state, no_flag_update => $otherOnly, clear_state => $otherOnly,
+ callback_choices => \&packageCallbackChoices);
+
+ if ($base || $otherOnly) {
+ foreach (keys %{$state->{selected}}) {
+ my $p = $packages->{depslist}[$_] or next;
+ #- if base is activated, propagate base flag to all selection.
+ $base and $p->set_flag_base;
+ $otherOnly and $otherOnly->{$_} = $state->{selected}{$_};
}
}
- $otherOnly and !packageFlagSelected($pkg) and $otherOnly->{packageName($pkg)} = 1;
- $otherOnly or packageSetFlagSelected($pkg, 1+packageFlagSelected($pkg));
1;
}
+
sub unselectPackage($$;$) {
my ($packages, $pkg, $otherOnly) = @_;
#- base package are not unselectable,
#- and already unselected package are no more unselectable.
- packageFlagBase($pkg) and return;
- packageFlagSelected($pkg) or return;
-
- #- dependancies may be used to propose package that may be not
- #- usefull for the user, since their counter is just one and
- #- they are not used any more by other packages.
- #- provides are closed and are taken into account to get possible
- #- unselection of package (value false on otherOnly) or strict
- #- unselection (value true on otherOnly).
- foreach my $provided ($pkg, packageProvides($packages, $pkg)) {
- packageFlagBase($provided) and die "a provided package cannot be a base package";
- if (packageFlagSelected($provided)) {
- my $unselect_alone = 1;
- foreach (packageDepsId($provided)) {
- $unselect_alone = 0;
- if (/\|/) {
- #- this package use a choice of other package, so we have to check
- #- if our package is not included in the choice, if this is the
- #- case, if must be checked one of the other package are selected.
- foreach (split '\|') {
- my $dep = packageById($packages, $_) or next;
- $dep == $pkg and $unselect_alone |= 1 and next;
- packageFlagBase($dep) || packageFlagSelected($dep) and $unselect_alone |= 2;
- }
- } else {
- packageById($packages, $_) == $pkg and $unselect_alone = 1;
- }
- $unselect_alone == 1 and last;
- }
- #- if package has been found and nothing more selected,
- #- deselect the provided, or we can ignore it safely.
- $provided == $pkg || $unselect_alone == 1 or next;
- $otherOnly or packageSetFlagSelected($provided, 0);
- $otherOnly and $otherOnly->{packageName($provided)} = 1;
- }
- foreach (map { split '\|' } packageDepsId($provided)) {
- my $dep = packageById($packages, $_) or next;
- packageFlagBase($dep) and next;
- packageFlagSelected($dep) or next;
- for (packageFlagSelected($dep)) {
- $_ == 1 and do { $otherOnly and $otherOnly->{packageName($dep)} ||= 0; };
- $_ > 1 and do { $otherOnly or packageSetFlagSelected($dep, $_-1); };
- last;
- }
- }
+ $pkg->flag_base and return;
+ $pkg->flag_selected or return;
+
+ #- try to unwind selection (requested or required) by keeping
+ #- rpmdb is right place.
+ #TODO
+ if ($otherOnly) {
+ $otherOnly->{$pkg->id} = undef;
+ } else {
+ $pkg->set_flag_requested(0);
+ $pkg->set_flag_required(0);
+
+ #- clear state.
+ my $state = $packages->{state} ||= {};
+ $state->{selected} = { $pkg->id };
+ $state->{requested} = {};
+ $packages->resolve_requested($packages->{rpmdb}, $state, clear_state => 1);
}
1;
}
sub togglePackageSelection($$;$) {
my ($packages, $pkg, $otherOnly) = @_;
- packageFlagSelected($pkg) ? unselectPackage($packages, $pkg, $otherOnly) : selectPackage($packages, $pkg, 0, $otherOnly);
+ $pkg->flag_selected ? unselectPackage($packages, $pkg, $otherOnly) : selectPackage($packages, $pkg, 0, $otherOnly);
}
sub setPackageSelection($$$) {
my ($packages, $pkg, $value) = @_;
@@ -336,20 +337,38 @@ sub setPackageSelection($$$) {
sub unselectAllPackages($) {
my ($packages) = @_;
- foreach (values %{$packages->{names}}) {
- unless (packageFlagBase($_) || packageFlagUpgrade($_)) {
- packageSetFlagSelected($_, 0);
+ my %selected;
+ foreach (@{$packages->{depslist}}) {
+ unless ($_->flag_base || $_->flag_installed && $_->flag_selected) {
+ #- deselect all packages except base or packages that need to be upgraded.
+ $_->set_flag_requested(0);
+ $_->set_flag_required(0);
+ $selected{$_->id} = undef;
}
}
+ if (%selected) {
+ my $state = $packages->{state} ||= {};
+ $state->{selected} = \%selected;
+ $state->{requested} = {};
+ $packages->resolve_requested($packages->{rpmdb}, $state, clear_state => 1);
+ }
}
sub unselectAllPackagesIncludingUpgradable($) {
my ($packages, $removeUpgradeFlag) = @_;
- foreach (values %{$packages->{names}}) {
- unless (packageFlagBase($_)) {
- packageSetFlagSelected($_, 0);
- packageSetFlagUpgrade($_, 0);
+ my %selected;
+ foreach (@{$packages->{depslist}}) {
+ unless ($_->flag_base) {
+ $_->set_flag_requested(0);
+ $_->set_flag_required(0);
+ $selected{$_->id} = undef;
}
}
+ if (%selected) {
+ my $state = $packages->{state} ||= {};
+ $state->{selected} = \%selected;
+ $state->{requested} = {};
+ $packages->resolve_requested($packages->{rpmdb}, $state, clear_state => 1);
+ }
}
sub psUpdateHdlistsDeps {
@@ -396,14 +415,18 @@ sub psUpdateHdlistsDeps {
}
#- this is necessary for urpmi.
- install_any::getAndSaveFile("Mandrake/base/$_", "$prefix/var/lib/urpmi/$_")
- foreach qw(depslist.ordered provides rpmsrate);
+ install_any::getAndSaveFile("Mandrake/base/$_", "$prefix/var/lib/urpmi/$_") foreach qw(rpmsrate);
}
sub psUsingHdlists {
my ($prefix, $method) = @_;
my $listf = install_any::getFile('Mandrake/base/hdlists') or die "no hdlists found";
- my %packages = ( names => {}, count => 0, depslist => [], mediums => {});
+ my $packages = new URPM;
+
+ #- add additional fields used by DrakX.
+ @{$packages}{qw(count mediums)} = (0, {});
+ $packages->{rpmdb} = URPM::DB::open($prefix);
+ $packages->{rpmdb} ||= new URPM;
#- parse hdlists file.
my $medium = 1;
@@ -415,15 +438,15 @@ sub psUsingHdlists {
#- make sure the first medium is always selected!
#- by default select all image.
- psUsingHdlist($prefix, $method, \%packages, $1, $medium, $2, $3, 1);
+ psUsingHdlist($prefix, $method, $packages, $1, $medium, $2, $3, 1);
++$medium;
}
- log::l("psUsingHdlists read " . scalar keys(%{$packages{names}}) .
- " headers on " . scalar keys(%{$packages{mediums}}) . " hdlists");
+ log::l("psUsingHdlists read " . scalar @{$packages->{depslist}} .
+ " headers on " . scalar keys(%{$packages->{mediums}}) . " hdlists");
- \%packages;
+ $packages;
}
sub psUsingHdlist {
@@ -441,8 +464,8 @@ sub psUsingHdlist {
rpmsdir => $rpmsdir, #- where is RPMS directory.
descr => $descr,
fakemedium => $fakemedium,
- min => $packages->{count},
- max => -1, #- will be updated after reading current hdlist.
+# min => $packages->{count},
+# max => -1, #- will be updated after reading current hdlist.
selected => $selected, #- default value is only CD1, it is really the minimal.
};
@@ -455,9 +478,9 @@ sub psUsingHdlist {
symlinkf $newf, "/tmp/$hdlist";
#- if $fhdlist is defined, this is preferable not to try to find the associated synthesis.
+ my $newsf = "$prefix/var/lib/urpmi/synthesis.hdlist.$fakemedium.cz" . ($hdlist =~ /\.cz2/ && "2");
unless ($fhdlist) {
#- copy existing synthesis file too.
- my $newsf = "$prefix/var/lib/urpmi/synthesis.hdlist.$fakemedium.cz" . ($hdlist =~ /\.cz2/ && "2");
install_any::getAndSaveFile("Mandrake/base/synthesis.$hdlist", $newsf);
$m->{synthesis_hdlist_size} = -s $newsf; #- keep track of size for post-check.
-s $newsf > 0 or unlink $newsf;
@@ -467,181 +490,148 @@ sub psUsingHdlist {
#- but keep all medium here so that urpmi has the whole set.
$method eq 'cdrom' && $medium > 1 && !common::usingRamdisk() and return;
- #- extract filename from archive, this take advantage of verifying
- #- the archive too.
- eval {
- require packdrake;
- my $packer = new packdrake($newf, quiet => 1);
- foreach (@{$packer->{files}}) {
- $packer->{data}{$_}[0] eq 'f' or next;
- my $pkg = [ (undef) x 8 ]; $pkg->[$FILE] = $_; $pkg->[$MEDIUM] = $medium;
- my $specific_arch = packageArch($pkg);
- if (!$specific_arch || MDK::Common::System::compat_arch($specific_arch)) {
- my $old_pkg = $packages->{names}{packageName($pkg)};
- if ($old_pkg) {
- my $epo_compare = 0; #- NO EPOCH AVAILABLE TODO packageEpoch($pkg) <=> packageEpoch($old_pkg);
- my $ver_compare = $epo_compare == 0 && versionCompare(packageVersion($pkg), packageVersion($old_pkg));
- my $rel_compare = $ver_compare == 0 && versionCompare(packageRelease($pkg), packageRelease($old_pkg));
- if ($epo_compare > 0 || $ver_compare > 0 || $rel_compare > 0 ||
- $epo_compare == 0 && $ver_compare == 0 && $rel_compare == 0 &&
- MDK::Common::System::better_arch($specific_arch, packageArch($old_pkg))) {
- log::l("replacing old package $old_pkg->[$FILE] with package $pkg->[$FILE]");
- foreach ($FILE, $MEDIUM) { #- TODO KEEP OLD PARAMETER
- $old_pkg->[$_] = $pkg->[$_];
- }
- packageFreeHeader($old_pkg);
- if (packageFlagInstalled($old_pkg)) {
- packageSetFlagInstalled($old_pkg, 0);
- selectPackage($packages, $old_pkg);
- }
- ++$relocated;
- } else {
- log::l("no need to replace previous package $old_pkg->[$FILE] with newer package $pkg->[$FILE]");
- ++$ignored;
- }
- } else {
- $packages->{names}{packageName($pkg)} = $pkg;
- ++$packages->{count}; #- take care of this one, so that desplist will be clean with index of package.
- }
- } else {
- log::l("ignoring package $_ with incompatible arch: $specific_arch");
- ++$ignored;
- }
- }
- };
-
- #- update maximal index.
- $m->{max} = $packages->{count} - 1;
- $m->{max} >= $m->{min} || $relocated > 0 || $ignored > 0 or die "nothing found while parsing $newf";
- $relocated > 0 and log::l("relocated $relocated headers in $hdlist");
- $ignored > 0 and log::l("ignored $ignored headers in $hdlist");
- log::l("read " . ($m->{max} - $m->{min} + 1) . " new headers in $hdlist");
+ #- parse synthesis (if available) of directly hdlist (with packing).
+ if (-s $newsf) {
+ ($m->{start}, $m->{end}) = $packages->parse_synthesis($newsf);
+ } elsif (-s $newf) {
+ ($m->{start}, $m->{end}) = $packages->parse_hdlist($newf, 1);
+ } else {
+ die "fatal: no hdlist nor synthesis to read for $fakemedium";
+ }
+ $m->{start} > $m->{end} and die "fatal: nothing read in hdlist or synthesis for $fakemedium";
+ log::l("read " . ($m->{end} - $m->{start} + 1) . " packages in $hdlist");
$m;
}
+#OBSOLETED TODO
sub getOtherDeps($$) {
- my ($packages, $f) = @_;
-
- #- this version of getDeps is customized for handling errors more easily and
- #- convert reference by name to deps id including closure computation.
- local $_;
- while (<$f>) {
- my ($name, $version, $release, $size, $deps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(\d+)\s+(.*)/;
- my $pkg = $packages->{names}{$name};
-
- $pkg or log::l("ignoring package $name-$version-$release in depslist is not in hdlist"), next;
- $version eq packageVersion($pkg) and $release eq packageRelease($pkg)
- or log::l("warning package $name-$version-$release in depslist mismatch version or release in hdlist ($version ne ",
- packageVersion($pkg), " or $release ne ", packageRelease($pkg), ")"), next;
-
- my $index = scalar @{$packages->{depslist}};
- $index >= packageMedium($packages, $pkg)->{min} && $index <= packageMedium($packages, $pkg)->{max}
- or log::l("ignoring package $name-$version-$release in depslist outside of hdlist indexation");
-
- #- here we have to translate referenced deps by name to id.
- #- this include a closure on deps too.
- my %closuredeps;
- @closuredeps{map { packageId($packages, $_), packageDepsId($_) }
- grep { $_ }
- map { packageByName($packages, $_) or do { log::l("unknown package $_ in depslist for closure"); undef } }
- split /\s+/, $deps} = ();
-
- $pkg->[$SIZE_DEPS] = join " ", $size, keys %closuredeps;
-
- push @{$packages->{depslist}}, $pkg;
- }
-
- #- check for same number of package in depslist and hdlists, avoid being to hard.
- scalar(keys %{$packages->{names}}) == scalar(@{$packages->{depslist}})
- or log::l("other depslist has not same package as hdlist file");
+ return; #TODO
+# my ($packages, $f) = @_;
+#
+# #- this version of getDeps is customized for handling errors more easily and
+# #- convert reference by name to deps id including closure computation.
+# local $_;
+# while (<$f>) {
+# my ($name, $version, $release, $size, $deps) = /^(\S*)-([^-\s]+)-([^-\s]+)\s+(\d+)\s+(.*)/;
+# my $pkg = $packages->{names}{$name};
+#
+# $pkg or log::l("ignoring package $name-$version-$release in depslist is not in hdlist"), next;
+# $version eq packageVersion($pkg) and $release eq packageRelease($pkg)
+# or log::l("warning package $name-$version-$release in depslist mismatch version or release in hdlist ($version ne ",
+# packageVersion($pkg), " or $release ne ", packageRelease($pkg), ")"), next;
+#
+# my $index = scalar @{$packages->{depslist}};
+# $index >= packageMedium($packages, $pkg)->{min} && $index <= packageMedium($packages, $pkg)->{max}
+# or log::l("ignoring package $name-$version-$release in depslist outside of hdlist indexation");
+#
+# #- here we have to translate referenced deps by name to id.
+# #- this include a closure on deps too.
+# my %closuredeps;
+# @closuredeps{map { packageId($packages, $_), packageDepsId($_) }
+# grep { $_ }
+# map { packageByName($packages, $_) or do { log::l("unknown package $_ in depslist for closure"); undef } }
+# split /\s+/, $deps} = ();
+#
+# $pkg->[$SIZE_DEPS] = join " ", $size, keys %closuredeps;
+#
+# push @{$packages->{depslist}}, $pkg;
+# }
+#
+# #- check for same number of package in depslist and hdlists, avoid being to hard.
+# scalar(keys %{$packages->{names}}) == scalar(@{$packages->{depslist}})
+# or log::l("other depslist has not same package as hdlist file");
}
+#OBSOLETED TODO
sub getDeps {
- my ($prefix, $packages) = @_;
-
- #- this is necessary for urpmi.
- install_any::getAndSaveFile('Mandrake/base/depslist.ordered', "$prefix/var/lib/urpmi/depslist.ordered");
- install_any::getAndSaveFile('Mandrake/base/provides', "$prefix/var/lib/urpmi/provides");
-
- #- beware of heavily mismatching depslist.ordered file against hdlist files.
- my $mismatch = 0;
-
- #- count the number of packages in deplist that are also in hdlist
- my $nb_deplist = 0;
-
- #- update dependencies list, provides attributes are updated later
- #- cross reference to be resolved on id (think of loop requires)
- #- provides should be updated after base flag has been set to save
- #- memory.
- local *F; open F, "$prefix/var/lib/urpmi/depslist.ordered" or die "can't find dependancies list";
- local $_;
- while (<F>) {
- my ($name, $version, $release, $arch, $epoch, $sizeDeps) =
- /^([^:\s]*)-([^:\-\s]+)-([^:\-\s]+)\.([^:\.\-\s]*)(?::(\d+)\S*)?\s+(.*)/;
- my $pkg = $packages->{names}{$name};
-
- #- these verification are necessary in case of error, but are no more fatal as
- #- in case of only one medium taken into account during install, there should be
- #- silent warning for package which are unknown at this point.
- $pkg or
- log::l("ignoring $name-$version-$release.$arch in depslist is not in hdlist");
- $pkg && $version ne packageVersion($pkg) and
- log::l("ignoring $name-$version-$release.$arch in depslist mismatch version in hdlist"), $pkg = undef;
- $pkg && $release ne packageRelease($pkg) and
- log::l("ignoring $name-$version-$release.$arch in depslist mismatch release in hdlist"), $pkg = undef;
- $pkg && $arch ne packageArch($pkg) and
- log::l("ignoring $name-$version-$release.$arch in depslist mismatch arch in hdlist"), $pkg = undef;
-
- if ($pkg) {
- $nb_deplist++;
- $epoch && $epoch > 0 and $pkg->[$EPOCH] = $epoch; #- only 5% of the distribution use epoch (serial).
- $pkg->[$SIZE_DEPS] = $sizeDeps;
-
- #- check position of package in depslist according to precomputed
- #- limit by hdlist, very strict :-)
- #- above warning have chance to raise an exception here, but may help
- #- for debugging.
- my $i = scalar @{$packages->{depslist}};
- $i >= packageMedium($packages, $pkg)->{min} && $i <= packageMedium($packages, $pkg)->{max} or
- log::l("inconsistency in position for $name-$version-$release.$arch in depslist and hdlist"), $mismatch = 1;
- }
-
- #- package are already sorted in depslist to enable small transaction and multiple medium.
- push @{$packages->{depslist}}, $pkg;
- }
-
- #- check for mismatching package, it should break with above die unless depslist has too many errors!
- $mismatch and die "depslist.ordered mismatch against hdlist files";
-
- #- check for same number of package in depslist and hdlists.
- my $nb_hdlist = keys %{$packages->{names}};
- $nb_hdlist == $nb_deplist or die "depslist.ordered has not same package as hdlist files ($nb_deplist != $nb_hdlist)";
+ return; #TODO
+# my ($prefix, $packages) = @_;
+#
+# #- this is necessary for urpmi.
+# install_any::getAndSaveFile('Mandrake/base/depslist.ordered', "$prefix/var/lib/urpmi/depslist.ordered");
+# install_any::getAndSaveFile('Mandrake/base/provides', "$prefix/var/lib/urpmi/provides");
+#
+# #- beware of heavily mismatching depslist.ordered file against hdlist files.
+# my $mismatch = 0;
+#
+# #- count the number of packages in deplist that are also in hdlist
+# my $nb_deplist = 0;
+#
+# #- update dependencies list, provides attributes are updated later
+# #- cross reference to be resolved on id (think of loop requires)
+# #- provides should be updated after base flag has been set to save
+# #- memory.
+# local *F; open F, "$prefix/var/lib/urpmi/depslist.ordered" or die "can't find dependancies list";
+# local $_;
+# while (<F>) {
+# my ($name, $version, $release, $arch, $epoch, $sizeDeps) =
+# /^([^:\s]*)-([^:\-\s]+)-([^:\-\s]+)\.([^:\.\-\s]*)(?::(\d+)\S*)?\s+(.*)/;
+# my $pkg = $packages->{names}{$name};
+#
+# #- these verification are necessary in case of error, but are no more fatal as
+# #- in case of only one medium taken into account during install, there should be
+# #- silent warning for package which are unknown at this point.
+# $pkg or
+# log::l("ignoring $name-$version-$release.$arch in depslist is not in hdlist");
+# $pkg && $version ne packageVersion($pkg) and
+# log::l("ignoring $name-$version-$release.$arch in depslist mismatch version in hdlist"), $pkg = undef;
+# $pkg && $release ne packageRelease($pkg) and
+# log::l("ignoring $name-$version-$release.$arch in depslist mismatch release in hdlist"), $pkg = undef;
+# $pkg && $arch ne packageArch($pkg) and
+# log::l("ignoring $name-$version-$release.$arch in depslist mismatch arch in hdlist"), $pkg = undef;
+#
+# if ($pkg) {
+# $nb_deplist++;
+# $epoch && $epoch > 0 and $pkg->[$EPOCH] = $epoch; #- only 5% of the distribution use epoch (serial).
+# $pkg->[$SIZE_DEPS] = $sizeDeps;
+#
+# #- check position of package in depslist according to precomputed
+# #- limit by hdlist, very strict :-)
+# #- above warning have chance to raise an exception here, but may help
+# #- for debugging.
+# my $i = scalar @{$packages->{depslist}};
+# $i >= packageMedium($packages, $pkg)->{min} && $i <= packageMedium($packages, $pkg)->{max} or
+# log::l("inconsistency in position for $name-$version-$release.$arch in depslist and hdlist"), $mismatch = 1;
+# }
+#
+# #- package are already sorted in depslist to enable small transaction and multiple medium.
+# push @{$packages->{depslist}}, $pkg;
+# }
+#
+# #- check for mismatching package, it should break with above die unless depslist has too many errors!
+# $mismatch and die "depslist.ordered mismatch against hdlist files";
+#
+# #- check for same number of package in depslist and hdlists.
+# my $nb_hdlist = keys %{$packages->{names}};
+# $nb_hdlist == $nb_deplist or die "depslist.ordered has not same package as hdlist files ($nb_deplist != $nb_hdlist)";
}
+#OBSOLETED TODO
sub getProvides($) {
- my ($packages) = @_;
-
- #- update provides according to dependencies, here are stored
- #- reference to package directly and choice are included, this
- #- assume only 1 of the choice is selected, else on unselection
- #- the provided package will be deleted where other package still
- #- need it.
- #- base package are not updated because they cannot be unselected,
- #- this save certainly a lot of memory since most of them may be
- #- needed by a large number of package.
- #- now using a packed of signed short, this means no more than 32768
- #- packages can be managed by DrakX (currently about 2000).
- my $i = 0;
- foreach my $pkg (@{$packages->{depslist}}) {
- $pkg or next;
- unless (packageFlagBase($pkg)) {
- foreach (map { split '\|' } grep { !/^NOTFOUND_/ } packageDepsId($pkg)) {
- my $provided = packageById($packages, $_) or next;
- packageFlagBase($provided) or $provided->[$PROVIDES] = pack "s*", (unpack "s*", $provided->[$PROVIDES]), $i;
- }
- }
- ++$i;
- }
+ return; #TODO
+# my ($packages) = @_;
+#
+# #- update provides according to dependencies, here are stored
+# #- reference to package directly and choice are included, this
+# #- assume only 1 of the choice is selected, else on unselection
+# #- the provided package will be deleted where other package still
+# #- need it.
+# #- base package are not updated because they cannot be unselected,
+# #- this save certainly a lot of memory since most of them may be
+# #- needed by a large number of package.
+# #- now using a packed of signed short, this means no more than 32768
+# #- packages can be managed by DrakX (currently about 2000).
+# my $i = 0;
+# foreach my $pkg (@{$packages->{depslist}}) {
+# $pkg or next;
+# unless (packageFlagBase($pkg)) {
+# foreach (map { split '\|' } grep { !/^NOTFOUND_/ } packageDepsId($pkg)) {
+# my $provided = packageById($packages, $_) or next;
+# packageFlagBase($provided) or $provided->[$PROVIDES] = pack "s*", (unpack "s*", $provided->[$PROVIDES]), $i;
+# }
+# }
+# ++$i;
+# }
}
sub read_rpmsrate {
@@ -691,25 +681,24 @@ sub read_rpmsrate {
foreach (split ' ', $data) {
if ($packages) {
my $p = packageByName($packages, $_) or next;
- my @m2 =
- map { if_($_ && packageName($_) =~ /locales-(.*)/, qq(LOCALES"$1")) }
- map { packageById($packages, $_) } packageDepsId($p);
-
+ my @m2 = map { if_(/locales-(.*)/, qq(LOCALES"$1")) } $p->requires_nosense;
my @m3 = ((grep { !/^\d$/ } @m), @m2);
if (member('INSTALL', @m3)) {
member('NOCOPY', @m3) or push @{$packages->{needToCopy} ||= []}, $_;
next; #- don't need to put INSTALL flag for a package.
}
- if (packageRate($p)) {
- my ($rate2, @m4) = packageRateRFlags($p);
+ if ($p->rate) {
+ my @m4 = $p->rflags;
if (@m3 > 1 || @m4 > 1) {
log::l("can't handle complicate flags for packages appearing twice ($_)");
$fatal_error++;
}
- log::l("package $_ appearing twice with different rates ($rate != $rate2)") if $rate != $rate2;
- packageSetRateRFlags($p, $rate, "$m3[0]||$m4[0]");
+ log::l("package $_ appearing twice with different rates ($rate != ".$p->rate.")") if $rate != $p->rate;
+ $p->set_rate($rate);
+ $p->set_rflags("$m3[0]||$m4[0]");
} else {
- packageSetRateRFlags($p, $rate, @m3);
+ $p->set_rate($rate);
+ $p->set_rflags(@m3);
}
} else {
print "$_ = ", join(" && ", @m), "\n";
@@ -755,10 +744,10 @@ sub saveCompssUsers {
my @fl = @{$compssUsers->{$_}{flags}};
my %fl; $fl{$_} = 1 foreach @fl;
$flat .= $compssUsers->{$_}{verbatim};
- foreach my $p (values %{$packages->{names}}) {
- my ($rate, @flags) = packageRateRFlags($p);
- if ($rate && grep { grep { !/^!/ && $fl{$_} } split('\|\|') } @flags) {
- $flat .= sprintf "\t%d %s\n", $rate, packageName($p);
+ foreach my $p (@{$packages->{depslist}}) {
+ my @flags = $p->rflags;
+ if ($p->rate && grep { grep { !/^!/ && $fl{$_} } split('\|\|') } @flags) {
+ $flat .= sprintf "\t%d %s\n", $p->rate, $p->name;
}
}
}
@@ -766,42 +755,46 @@ sub saveCompssUsers {
}
sub setSelectedFromCompssList {
- my ($packages, $compssUsersChoice, $min_level, $max_size, $otherOnly) = @_;
+ my ($packages, $compssUsersChoice, $min_level, $max_size) = @_;
$compssUsersChoice->{TRUE} = 1; #- ensure TRUE is set
my $nb = selectedSize($packages);
- foreach my $p (sort { packageRate($b) <=> packageRate($a) } values %{$packages->{names}}) {
- my ($rate, @flags) = packageRateRFlags($p);
+ foreach my $p (sort { $b->rate <=> $a->rate } @{$packages->{depslist}}) {
+ my @flags = $p->rflags;
next if
- !$rate || $rate < $min_level ||
+ !$p->rate || $p->rate < $min_level ||
grep { !grep { /^!(.*)/ ? !$compssUsersChoice->{$1} : $compssUsersChoice->{$_} } split('\|\|') } @flags;
#- determine the packages that will be selected when
#- selecting $p. the packages are not selected.
- my %newSelection;
- selectPackage($packages, $p, 0, \%newSelection);
+ my $state = $packages->{state} ||= {};
+ $state->{selected} = {};
+ $state->{requested} = packageRequest($packages, $p) || {};
+
+ $packages->resolve_requested($packages->{rpmdb}, $state, no_flag_update => 1,
+ callback_choices => \&packageCallbackChoices);
#- this enable an incremental total size.
my $old_nb = $nb;
- foreach (grep { $newSelection{$_} } keys %newSelection) {
- $nb += packageSize($packages->{names}{$_});
+ foreach (keys %{$state->{selected}}) {
+ my $p = $packages->{depslist}[$_] or next;
+ $nb += $p->size;
}
if ($max_size && $nb > $max_size) {
$nb = $old_nb;
- $min_level = packageRate($p);
+ $min_level = $p->rate;
+ $state->{requested} = {}; #- ensure no newer package will be selected.
+ $packages->resolve_requested($packages->{rpmdb}, $state, clear_state => 1);
last;
}
- #- at this point the package can safely be selected.
- if ($otherOnly) {
- selectPackage($packages, $p, 0, $otherOnly);
- } else {
- selectPackage($packages, $p);
+ #- do the effective selection (was not done due to no_flag_update option used.
+ foreach (keys %{$state->{selected}}) {
+ my $pkg = $packages->{depslist}[$_];
+ $state->{selected}{$_} ? $pkg->set_flag_requested : $pkg->set_flag_required;
}
}
- unless ($otherOnly) {
- log::l("setSelectedFromCompssList: reached size ", formatXiB($nb), ", up to indice $min_level (less than ", formatXiB($max_size), ")");
- log::l("setSelectedFromCompssList: ", join(" ", sort map { packageName($_) } grep { packageFlagSelected($_) } @{$packages->{depslist}}));
- }
+ log::l("setSelectedFromCompssList: reached size ", formatXiB($nb), ", up to indice $min_level (less than ", formatXiB($max_size), ")");
+ log::l("setSelectedFromCompssList: ", join(" ", sort map { $_->name } grep { $_->flag_selected } @{$packages->{depslist}}));
$min_level;
}
@@ -809,13 +802,17 @@ sub setSelectedFromCompssList {
#- just saves the selected packages, call setSelectedFromCompssList and restores the selected packages
sub saveSelected {
my ($packages) = @_;
- my @l = values %{$packages->{names}};
- my @flags = map { packageFlagSelected($_) } @l;
+ my @l = @{$packages->{depslist}};
+ my @flags = map { ($_->flag_requested && 1) + ($_->flag_required && 2) + ($_->flag_upgrade && 4) } @l;
[ $packages, \@l, \@flags ];
}
sub restoreSelected {
my ($packages, $l, $flags) = @{$_[0]};
- mapn { packageSetFlagSelected(@_) } $l, $flags;
+ mapn { my ($pkg, $flag) = @_;
+ $pkg->set_flag_requested($flag & 1);
+ $pkg->set_flag_required($flag & 2);
+ $pkg->set_flag_upgrade($flag & 4);
+ } $l, $flags;
}
sub computeGroupSize {
@@ -860,30 +857,31 @@ sub computeGroupSize {
}
my (%group, %memo);
- foreach my $p (values %{$packages->{names}}) {
- my ($rate, @flags) = packageRateRFlags($p);
- next if !$rate || $rate < $min_level;
+ foreach my $p (@{$packages->{depslist}}) {
+ my @flags = $p->rflags;
+ next if !$p->rate || $p->rate < $min_level;
my $flags = join("\t", @flags = or_ify(@flags));
- $group{packageName($p)} = ($memo{$flags} ||= or_clean(@flags));
+ $group{$p->name} = ($memo{$flags} ||= or_clean(@flags));
#- determine the packages that will be selected when selecting $p. the packages are not selected.
my %newSelection;
selectPackage($packages, $p, 0, \%newSelection);
- foreach (grep { $newSelection{$_} } keys %newSelection) {
- my $s = $group{$_} || do {
- $packages->{names}{$_}[$VALUES] =~ /\t(.*)/;
- join("\t", or_ify(split("\t", $1)));
+ foreach (keys %newSelection) {
+ my $p = $packages->{depslist}[$_] or next;
+ my $s = $group{$p->name} || do {
+ join("\t", or_ify($p->rflags));
};
next if length($s) > 80; # HACK, truncated too complicated expressions, too costly
my $m = "$flags\t$s";
- $group{$_} = ($memo{$m} ||= or_clean(@flags, split("\t", $s)));
+ $group{$p->name} = ($memo{$m} ||= or_clean(@flags, split("\t", $s)));
}
}
my (%sizes, %pkgs);
while (my ($k, $v) = each %group) {
+ my $pkg = packageByName($packages, $k) or next;
push @{$pkgs{$v}}, $k;
- $sizes{$v} += packageSize($packages->{names}{$k});
+ $sizes{$v} += $pkg->size;
}
log::l(sprintf "%s %dMB %s", $_, $sizes{$_} / sqr(1024), join(',', @{$pkgs{$_}})) foreach keys %sizes;
\%sizes, \%pkgs;
@@ -899,19 +897,11 @@ sub init_db {
CORE::select((CORE::select(LOG), $| = 1)[0]);
c::rpmErrorSetCallback(fileno LOG);
#- c::rpmSetVeryVerbose();
-
- log::l("reading /usr/lib/rpm/rpmrc");
- c::rpmReadConfigFiles() or die "can't read rpm config files";
- log::l("\tdone");
}
sub rebuild_db_open_for_traversal {
my ($packages, $prefix) = @_;
- log::l("reading /usr/lib/rpm/rpmrc");
- c::rpmReadConfigFiles() or die "can't read rpm config files";
- log::l("\tdone");
-
unless (exists $packages->{rebuild_db}) {
if (my $pid = fork()) {
waitpid $pid, 0;
@@ -921,14 +911,14 @@ sub rebuild_db_open_for_traversal {
my $rebuilddb_dir = "$prefix/var/lib/rpmrebuilddb.$$";
-d $rebuilddb_dir and log::l("removing stale directory $rebuilddb_dir"), rm_rf($rebuilddb_dir);
- c::rpmdbRebuild($prefix) or log::l("rebuilding of rpm database failed: ". c::rpmErrorString()), c::_exit(2);
+ URPM::DB::rebuild($prefix) or log::l("rebuilding of rpm database failed: ". c::rpmErrorString()), c::_exit(2);
c::_exit(0);
}
$packages->{rebuild_db} = undef;
}
- my $db = c::rpmdbOpenForTraversal($prefix) or die "unable to open $prefix/var/lib/rpm/Packages";
+ my $db = URPM::DB::open($prefix) or die "unable to open $prefix/var/lib/rpm/Packages";
log::l("opened rpm database for examining existing packages");
$db;
@@ -960,19 +950,6 @@ sub done_db {
close LOG;
}
-sub versionCompare($$) {
- goto &c::rpmvercmp;
-}
-#- old code using perl version, still broken on some case.
-#- my ($a, $b) = @_;
-#- local $_;
-#-
-#- while ($a || $b) {
-#- my ($sb, $sa) = map { $1 if $a =~ /^\W*\d/ ? s/^\W*0*(\d+)// : s/^\W*(\D*)// } ($b, $a);
-#- $_ = ($sa =~ /^\d/ || $sb =~ /^\d/) && length($sa) <=> length($sb) || $sa cmp $sb and return $_ || 0;
-#- $sa eq '' && $sb eq '' and return $a cmp $b || 0;
-#- }
-
sub selectPackagesAlreadyInstalled {
my ($packages, $prefix) = @_;
@@ -980,340 +957,349 @@ sub selectPackagesAlreadyInstalled {
$packages->{rebuild_db} = "oem does not need rebuilding the rpm db";
my $db = rebuild_db_open_for_traversal($packages, $prefix);
- #- this method has only one objectif, check the presence of packages
- #- already installed and avoid installing them again. this is to be used
- #- with oem installation, if the database exists, preselect the packages
- #- installed WHATEVER their version/release (log if a problem is perceived
- #- is enough).
- c::rpmdbTraverse($db, sub {
- my ($header) = @_;
- my $p = $packages->{names}{c::headerGetEntry($header, 'name')};
-
- if ($p) {
- my $epoch_cmp = c::headerGetEntry($header, 'epoch') <=> packageEpoch($p);
- my $version_cmp = $epoch_cmp == 0 && versionCompare(c::headerGetEntry($header, 'version'),
- packageVersion($p));
- my $version_rel_test = $epoch_cmp > 0 || $epoch_cmp == 0 &&
- ($version_cmp > 0 || $version_cmp == 0 &&
- versionCompare(c::headerGetEntry($header, 'release'), packageRelease($p)) >= 0);
- $version_rel_test or log::l("keeping an older package, avoiding selecting $p->[$FILE]");
- packageSetFlagInstalled($p, 1);
- }
- });
-
- #- close db, job finished !
- c::rpmdbClose($db);
+ $packages->compute_installed_flags($db);
log::l("done selecting packages to upgrade");
}
+#OBSOLETED TODO
sub selectPackagesToUpgrade($$$;$$) {
- my ($packages, $prefix, $base, $toRemove, $toSave) = @_;
- local $_; #- else perl complains on the map { ... } grep { ... } @...;
-
- local (*UPGRADE_INPUT, *UPGRADE_OUTPUT); pipe UPGRADE_INPUT, UPGRADE_OUTPUT;
- if (my $pid = fork()) {
- @{$toRemove || []} = (); #- reset this one.
-
- close UPGRADE_OUTPUT;
- while (<UPGRADE_INPUT>) {
- chomp;
- my ($action, $name) = /^([\w\d]*):(.*)/;
- for ($action) {
- /remove/ and do { push @$toRemove, $name; next };
- /keepfiles/ and do { push @$toSave, $name; next };
-
- my $p = $packages->{names}{$name} or die "unable to find package ($name)";
- /^\d*$/ and do { $p->[$INSTALLED_CUMUL_SIZE] = $action; next };
- /installed/ and do { packageSetFlagInstalled($p, 1); next };
- /select/ and do { selectPackage($packages, $p); next };
-
- die "unknown action ($action)";
- }
- }
- close UPGRADE_INPUT;
- waitpid $pid, 0;
- } else {
- close UPGRADE_INPUT;
-
- my $db = rebuild_db_open_for_traversal($packages, $prefix);
- #- used for package that are not correctly updated.
- #- should only be used when nothing else can be done correctly.
- my %upgradeNeedRemove = (
-# 'libstdc++' => 1,
-# 'compat-glibc' => 1,
-# 'compat-libs' => 1,
- );
-
- #- generel purpose for forcing upgrade of package whatever version is.
- my %packageNeedUpgrade = (
- #'lilo' => 1, #- this package has been misnamed in 7.0.
- );
-
- #- help removing package which may have different release numbering
- my %toRemove; map { $toRemove{$_} = 1 } @{$toRemove || []};
-
- #- help searching package to upgrade in regard to already installed files.
- my %installedFilesForUpgrade;
-
- #- help keeping memory by this set of package that have been obsoleted.
- my %obsoletedPackages;
-
- #- make a subprocess here for reading filelist, this is important
- #- not to waste a lot of memory for the main program which will fork
- #- latter for each transaction.
- local (*INPUT, *OUTPUT_CHILD); pipe INPUT, OUTPUT_CHILD;
- local (*INPUT_CHILD, *OUTPUT); pipe INPUT_CHILD, OUTPUT;
- if (my $pid = fork()) {
- close INPUT_CHILD;
- close OUTPUT_CHILD;
- select((select(OUTPUT), $| = 1)[0]);
-
- #- internal reading from interactive mode of parsehdlist.
- #- takes a code to call with the line read, this avoid allocating
- #- memory for that.
- my $ask_child = sub {
- my ($name, $tag, $code) = @_;
- $code or die "no callback code for parsehdlist output";
- print OUTPUT "$name:$tag\n";
+ return;
+# my ($packages, $prefix, $base, $toRemove, $toSave) = @_;
+# local $_; #- else perl complains on the map { ... } grep { ... } @...;
+#
+# local (*UPGRADE_INPUT, *UPGRADE_OUTPUT); pipe UPGRADE_INPUT, UPGRADE_OUTPUT;
+# if (my $pid = fork()) {
+# @{$toRemove || []} = (); #- reset this one.
+#
+# close UPGRADE_OUTPUT;
+# while (<UPGRADE_INPUT>) {
+# chomp;
+# my ($action, $name) = /^([\w\d]*):(.*)/;
+# for ($action) {
+# /remove/ and do { push @$toRemove, $name; next };
+# /keepfiles/ and do { push @$toSave, $name; next };
+#
+# my $p = $packages->{names}{$name} or die "unable to find package ($name)";
+# /^\d*$/ and do { $p->[$INSTALLED_CUMUL_SIZE] = $action; next };
+# /installed/ and do { packageSetFlagInstalled($p, 1); next };
+# /select/ and do { selectPackage($packages, $p); next };
+#
+# die "unknown action ($action)";
+# }
+# }
+# close UPGRADE_INPUT;
+# waitpid $pid, 0;
+# } else {
+# close UPGRADE_INPUT;
+#
+# my $db = rebuild_db_open_for_traversal($packages, $prefix);
+# #- used for package that are not correctly updated.
+# #- should only be used when nothing else can be done correctly.
+# my %upgradeNeedRemove = (
+## 'libstdc++' => 1,
+## 'compat-glibc' => 1,
+## 'compat-libs' => 1,
+# );
+#
+# #- generel purpose for forcing upgrade of package whatever version is.
+# my %packageNeedUpgrade = (
+# #'lilo' => 1, #- this package has been misnamed in 7.0.
+# );
+#
+# #- help removing package which may have different release numbering
+# my %toRemove; map { $toRemove{$_} = 1 } @{$toRemove || []};
+#
+# #- help searching package to upgrade in regard to already installed files.
+# my %installedFilesForUpgrade;
+#
+# #- help keeping memory by this set of package that have been obsoleted.
+# my %obsoletedPackages;
+#
+# #- make a subprocess here for reading filelist, this is important
+# #- not to waste a lot of memory for the main program which will fork
+# #- latter for each transaction.
+# local (*INPUT, *OUTPUT_CHILD); pipe INPUT, OUTPUT_CHILD;
+# local (*INPUT_CHILD, *OUTPUT); pipe INPUT_CHILD, OUTPUT;
+# if (my $pid = fork()) {
+# close INPUT_CHILD;
+# close OUTPUT_CHILD;
+# select((select(OUTPUT), $| = 1)[0]);
+#
+# #- internal reading from interactive mode of parsehdlist.
+# #- takes a code to call with the line read, this avoid allocating
+# #- memory for that.
+# my $ask_child = sub {
+# my ($name, $tag, $code) = @_;
+# $code or die "no callback code for parsehdlist output";
+# print OUTPUT "$name:$tag\n";
+#
+# local $_;
+# while (<INPUT>) {
+# chomp;
+# /^\s*$/ and last;
+# $code->($_);
+# }
+# };
+#
+# #- select packages which obseletes other package, obselete package are not removed,
+# #- should we remove them ? this could be dangerous !
+# foreach my $p (values %{$packages->{names}}) {
+# $ask_child->(packageName($p), "obsoletes", sub {
+# #- take care of flags and version and release if present
+# local ($_) = @_;
+# if (my ($n,$o,$v,$r) = /^(\S*)\s*(\S*)\s*([^\s-]*)-?(\S*)/) {
+# my $obsoleted = 0;
+# my $check_obsoletes = sub {
+# my ($header) = @_;
+# (!$v || eval(versionCompare(c::headerGetEntry($header, 'version'), $v) . $o . 0)) &&
+# (!$r || versionCompare(c::headerGetEntry($header, 'version'), $v) != 0 ||
+# eval(versionCompare(c::headerGetEntry($header, 'release'), $r) . $o . 0)) or return;
+# ++$obsoleted;
+# };
+# c::rpmdbNameTraverse($db, $n, $check_obsoletes);
+# if ($obsoleted > 0) {
+# log::l("selecting " . packageName($p) . " by selection on obsoletes");
+# $obsoletedPackages{$1} = undef;
+# selectPackage($packages, $p);
+# }
+# }
+# });
+# }
+#
+# #- mark all files which are not in /etc/rc.d/ for packages which are already installed but which
+# #- are not in the packages list to upgrade.
+# #- the 'installed' property will make a package unable to be selected, look at select.
+# c::rpmdbTraverse($db, sub {
+# my ($header) = @_;
+# my $otherPackage = (c::headerGetEntry($header, 'release') !~ /mdk\w*$/ &&
+# (c::headerGetEntry($header, 'name'). '-' .
+# c::headerGetEntry($header, 'version'). '-' .
+# c::headerGetEntry($header, 'release')));
+# my $p = $packages->{names}{c::headerGetEntry($header, 'name')};
+#
+# if ($p) {
+# my $epoch_cmp = c::headerGetEntry($header, 'epoch') <=> packageEpoch($p);
+# my $version_cmp = $epoch_cmp == 0 && versionCompare(c::headerGetEntry($header, 'version'),
+# packageVersion($p));
+# my $version_rel_test = $epoch_cmp > 0 || $epoch_cmp == 0 &&
+# ($version_cmp > 0 || $version_cmp == 0 &&
+# versionCompare(c::headerGetEntry($header, 'release'), packageRelease($p)) >= 0);
+# if ($packageNeedUpgrade{packageName($p)}) {
+# log::l("package ". packageName($p) ." need to be upgraded");
+# } elsif ($version_rel_test) { #- by default, package are upgraded whatever version is !
+# if ($otherPackage && $version_cmp <= 0) {
+# log::l("force upgrading $otherPackage since it will not be updated otherwise");
+# } else {
+# #- let the parent known this installed package.
+# print UPGRADE_OUTPUT "installed:" . packageName($p) . "\n";
+# packageSetFlagInstalled($p, 1);
+# }
+# } elsif ($upgradeNeedRemove{packageName($p)}) {
+# my $otherPackage = (c::headerGetEntry($header, 'name'). '-' .
+# c::headerGetEntry($header, 'version'). '-' .
+# c::headerGetEntry($header, 'release'));
+# log::l("removing $otherPackage since it will not upgrade correctly!");
+# $toRemove{$otherPackage} = 1; #- force removing for theses other packages, select our.
+# }
+# } else {
+# if (exists $obsoletedPackages{c::headerGetEntry($header, 'name')}) {
+# my @files = c::headerGetEntry($header, 'filenames');
+# @installedFilesForUpgrade{grep { ($_ !~ m|^/dev/| && $_ !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| &&
+# ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = ();
+# }
+# }
+# });
+#
+# #- find new packages to upgrade.
+# foreach my $p (values %{$packages->{names}}) {
+# my $skipThis = 0;
+# my $count = c::rpmdbNameTraverse($db, packageName($p), sub {
+# my ($header) = @_;
+# $skipThis ||= packageFlagInstalled($p);
+# });
+#
+# #- skip if not installed (package not found in current install).
+# $skipThis ||= ($count == 0);
+#
+# #- make sure to upgrade package that have to be upgraded.
+# $packageNeedUpgrade{packageName($p)} and $skipThis = 0;
+#
+# #- select the package if it is already installed with a lower version or simply not installed.
+# unless ($skipThis) {
+# my $cumulSize;
+#
+# selectPackage($packages, $p);
+#
+# #- keep in mind installed files which are not being updated. doing this costs in
+# #- execution time but use less memory, else hash all installed files and unhash
+# #- all file for package marked for upgrade.
+# c::rpmdbNameTraverse($db, packageName($p), sub {
+# my ($header) = @_;
+# $cumulSize += c::headerGetEntry($header, 'size');
+# my @files = c::headerGetEntry($header, 'filenames');
+# @installedFilesForUpgrade{grep { ($_ !~ m|^/dev/| && $_ !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| &&
+# ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = ();
+# });
+#
+# $ask_child->(packageName($p), "files", sub {
+# delete $installedFilesForUpgrade{$_[0]};
+# });
+#
+# #- keep in mind the cumul size of installed package since they will be deleted
+# #- on upgrade, only for package that are allowed to be upgraded.
+# if (allowedToUpgrade(packageName($p))) {
+# print UPGRADE_OUTPUT "$cumulSize:" . packageName($p) . "\n";
+# }
+# }
+# }
+#
+# #- unmark all files for all packages marked for upgrade. it may not have been done above
+# #- since some packages may have been selected by depsList.
+# foreach my $p (values %{$packages->{names}}) {
+# if (packageFlagSelected($p)) {
+# $ask_child->(packageName($p), "files", sub {
+# delete $installedFilesForUpgrade{$_[0]};
+# });
+# }
+# }
+#
+# #- select packages which contains marked files, then unmark on selection.
+# #- a special case can be made here, the selection is done only for packages
+# #- requiring locales if the locales are selected.
+# #- another special case are for devel packages where fixes over the time has
+# #- made some files moving between the normal package and its devel couterpart.
+# #- if only one file is affected, no devel package is selected.
+# foreach my $p (values %{$packages->{names}}) {
+# unless (packageFlagSelected($p)) {
+# my $toSelect = 0;
+# $ask_child->(packageName($p), "files", sub {
+# if ($_[0] !~ m|^/dev/| && $_[0] !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && exists $installedFilesForUpgrade{$_[0]}) {
+# ++$toSelect if ! -d "$prefix/$_[0]" && ! -l "$prefix/$_[0]";
+# }
+# delete $installedFilesForUpgrade{$_[0]};
+# });
+# if ($toSelect) {
+# if ($toSelect <= 1 && packageName($p) =~ /-devel/) {
+# log::l("avoid selecting " . packageName($p) . " as not enough files will be updated");
+# } else {
+# #- default case is assumed to allow upgrade.
+# my @deps = map { my $p = packageById($packages, $_);
+# if_($p && packageName($p) =~ /locales-/, $p) } packageDepsId($p);
+# if (@deps == 0 || @deps > 0 && (grep { !packageFlagSelected($_) } @deps) == 0) {
+# log::l("selecting " . packageName($p) . " by selection on files");
+# selectPackage($packages, $p);
+# } else {
+# log::l("avoid selecting " . packageName($p) . " as its locales language is not already selected");
+# }
+# }
+# }
+# }
+# }
+#
+# #- clean memory...
+# %installedFilesForUpgrade = ();
+#
+# #- no need to still use the child as this point, we can let him to terminate.
+# close OUTPUT;
+# close INPUT;
+# waitpid $pid, 0;
+# } else {
+# close INPUT;
+# close OUTPUT;
+# open STDIN, "<&INPUT_CHILD";
+# open STDOUT, ">&OUTPUT_CHILD";
+# exec if_($ENV{LD_LOADER}, $ENV{LD_LOADER}), "parsehdlist", "--interactive", map { "/tmp/$_->{hdlist}" } values %{$packages->{mediums}}
+# or c::_exit(1);
+# }
+#
+# #- let the parent known about what we found here!
+# foreach my $p (values %{$packages->{names}}) {
+# print UPGRADE_OUTPUT "select:" . packageName($p) . "\n" if packageFlagSelected($p);
+# }
+#
+# #- clean false value on toRemove.
+# delete $toRemove{''};
+#
+# #- get filenames that should be saved for packages to remove.
+# #- typically config files, but it may broke for packages that
+# #- are very old when compabilty has been broken.
+# #- but new version may saved to .rpmnew so it not so hard !
+# if ($toSave && keys %toRemove) {
+# c::rpmdbTraverse($db, sub {
+# my ($header) = @_;
+# my $otherPackage = (c::headerGetEntry($header, 'name'). '-' .
+# c::headerGetEntry($header, 'version'). '-' .
+# c::headerGetEntry($header, 'release'));
+# if ($toRemove{$otherPackage}) {
+# print UPGRADE_OUTPUT "remove:$otherPackage\n";
+# if (packageFlagBase($packages->{names}{c::headerGetEntry($header, 'name')})) {
+# delete $toRemove{$otherPackage}; #- keep it selected, but force upgrade.
+# } else {
+# my @files = c::headerGetEntry($header, 'filenames');
+# my @flags = c::headerGetEntry($header, 'fileflags');
+# for my $i (0..$#flags) {
+# if ($flags[$i] & c::RPMFILE_CONFIG()) {
+# print UPGRADE_OUTPUT "keepfiles:$files[$i]\n" unless $files[$i] =~ /kdelnk/;
+# }
+# }
+# }
+# }
+# });
+# }
+#
+# #- close db, job finished !
+# c::rpmdbClose($db);
+# log::l("done selecting packages to upgrade");
+#
+# close UPGRADE_OUTPUT;
+# c::_exit(0);
+# }
+#
+# #- keep a track of packages that are been selected for being upgraded,
+# #- these packages should not be unselected (unless expertise)
+# foreach my $p (values %{$packages->{names}}) {
+# packageSetFlagUpgrade($p, 1) if packageFlagSelected($p);
+# }
+}
- local $_;
- while (<INPUT>) {
- chomp;
- /^\s*$/ and last;
- $code->($_);
- }
- };
+sub allowedToUpgrade { $_[0] !~ /^(kernel|kernel22|kernel2.2|kernel-secure|kernel-smp|kernel-linus|kernel-linus2.2|hackkernel|kernel-enterprise)$/ }
- #- select packages which obseletes other package, obselete package are not removed,
- #- should we remove them ? this could be dangerous !
- foreach my $p (values %{$packages->{names}}) {
- $ask_child->(packageName($p), "obsoletes", sub {
- #- take care of flags and version and release if present
- local ($_) = @_;
- if (my ($n,$o,$v,$r) = /^(\S*)\s*(\S*)\s*([^\s-]*)-?(\S*)/) {
- my $obsoleted = 0;
- my $check_obsoletes = sub {
- my ($header) = @_;
- (!$v || eval(versionCompare(c::headerGetEntry($header, 'version'), $v) . $o . 0)) &&
- (!$r || versionCompare(c::headerGetEntry($header, 'version'), $v) != 0 ||
- eval(versionCompare(c::headerGetEntry($header, 'release'), $r) . $o . 0)) or return;
- ++$obsoleted;
- };
- c::rpmdbNameTraverse($db, $n, $check_obsoletes);
- if ($obsoleted > 0) {
- log::l("selecting " . packageName($p) . " by selection on obsoletes");
- $obsoletedPackages{$1} = undef;
- selectPackage($packages, $p);
- }
- }
- });
- }
+sub installTransactionClosure {
+ my ($packages, $id2pkg) = @_;
+ my ($id, %closure, @l);
- #- mark all files which are not in /etc/rc.d/ for packages which are already installed but which
- #- are not in the packages list to upgrade.
- #- the 'installed' property will make a package unable to be selected, look at select.
- c::rpmdbTraverse($db, sub {
- my ($header) = @_;
- my $otherPackage = (c::headerGetEntry($header, 'release') !~ /mdk\w*$/ &&
- (c::headerGetEntry($header, 'name'). '-' .
- c::headerGetEntry($header, 'version'). '-' .
- c::headerGetEntry($header, 'release')));
- my $p = $packages->{names}{c::headerGetEntry($header, 'name')};
-
- if ($p) {
- my $epoch_cmp = c::headerGetEntry($header, 'epoch') <=> packageEpoch($p);
- my $version_cmp = $epoch_cmp == 0 && versionCompare(c::headerGetEntry($header, 'version'),
- packageVersion($p));
- my $version_rel_test = $epoch_cmp > 0 || $epoch_cmp == 0 &&
- ($version_cmp > 0 || $version_cmp == 0 &&
- versionCompare(c::headerGetEntry($header, 'release'), packageRelease($p)) >= 0);
- if ($packageNeedUpgrade{packageName($p)}) {
- log::l("package ". packageName($p) ." need to be upgraded");
- } elsif ($version_rel_test) { #- by default, package are upgraded whatever version is !
- if ($otherPackage && $version_cmp <= 0) {
- log::l("force upgrading $otherPackage since it will not be updated otherwise");
- } else {
- #- let the parent known this installed package.
- print UPGRADE_OUTPUT "installed:" . packageName($p) . "\n";
- packageSetFlagInstalled($p, 1);
- }
- } elsif ($upgradeNeedRemove{packageName($p)}) {
- my $otherPackage = (c::headerGetEntry($header, 'name'). '-' .
- c::headerGetEntry($header, 'version'). '-' .
- c::headerGetEntry($header, 'release'));
- log::l("removing $otherPackage since it will not upgrade correctly!");
- $toRemove{$otherPackage} = 1; #- force removing for theses other packages, select our.
- }
- } else {
- if (exists $obsoletedPackages{c::headerGetEntry($header, 'name')}) {
- my @files = c::headerGetEntry($header, 'filenames');
- @installedFilesForUpgrade{grep { ($_ !~ m|^/dev/| && $_ !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| &&
- ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = ();
- }
- }
- });
-
- #- find new packages to upgrade.
- foreach my $p (values %{$packages->{names}}) {
- my $skipThis = 0;
- my $count = c::rpmdbNameTraverse($db, packageName($p), sub {
- my ($header) = @_;
- $skipThis ||= packageFlagInstalled($p);
- });
-
- #- skip if not installed (package not found in current install).
- $skipThis ||= ($count == 0);
-
- #- make sure to upgrade package that have to be upgraded.
- $packageNeedUpgrade{packageName($p)} and $skipThis = 0;
-
- #- select the package if it is already installed with a lower version or simply not installed.
- unless ($skipThis) {
- my $cumulSize;
-
- selectPackage($packages, $p);
-
- #- keep in mind installed files which are not being updated. doing this costs in
- #- execution time but use less memory, else hash all installed files and unhash
- #- all file for package marked for upgrade.
- c::rpmdbNameTraverse($db, packageName($p), sub {
- my ($header) = @_;
- $cumulSize += c::headerGetEntry($header, 'size');
- my @files = c::headerGetEntry($header, 'filenames');
- @installedFilesForUpgrade{grep { ($_ !~ m|^/dev/| && $_ !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| &&
- ! -d "$prefix/$_" && ! -l "$prefix/$_") } @files} = ();
- });
-
- $ask_child->(packageName($p), "files", sub {
- delete $installedFilesForUpgrade{$_[0]};
- });
-
- #- keep in mind the cumul size of installed package since they will be deleted
- #- on upgrade, only for package that are allowed to be upgraded.
- if (allowedToUpgrade(packageName($p))) {
- print UPGRADE_OUTPUT "$cumulSize:" . packageName($p) . "\n";
- }
- }
- }
+ @l = sort { $a <=> $b } keys %$id2pkg;
+ while (defined($id = shift @l)) {
+ my @l2 = ($id);
- #- unmark all files for all packages marked for upgrade. it may not have been done above
- #- since some packages may have been selected by depsList.
- foreach my $p (values %{$packages->{names}}) {
- if (packageFlagSelected($p)) {
- $ask_child->(packageName($p), "files", sub {
- delete $installedFilesForUpgrade{$_[0]};
- });
- }
- }
+ while (defined($id = shift @l2)) {
+ exists $closure{$id} and next;
+ $closure{$id} = undef;
- #- select packages which contains marked files, then unmark on selection.
- #- a special case can be made here, the selection is done only for packages
- #- requiring locales if the locales are selected.
- #- another special case are for devel packages where fixes over the time has
- #- made some files moving between the normal package and its devel couterpart.
- #- if only one file is affected, no devel package is selected.
- foreach my $p (values %{$packages->{names}}) {
- unless (packageFlagSelected($p)) {
- my $toSelect = 0;
- $ask_child->(packageName($p), "files", sub {
- if ($_[0] !~ m|^/dev/| && $_[0] !~ m|^/etc/rc.d/| && $_ !~ m|\.la$| && exists $installedFilesForUpgrade{$_[0]}) {
- ++$toSelect if ! -d "$prefix/$_[0]" && ! -l "$prefix/$_[0]";
- }
- delete $installedFilesForUpgrade{$_[0]};
- });
- if ($toSelect) {
- if ($toSelect <= 1 && packageName($p) =~ /-devel/) {
- log::l("avoid selecting " . packageName($p) . " as not enough files will be updated");
- } else {
- #- default case is assumed to allow upgrade.
- my @deps = map { my $p = packageById($packages, $_);
- if_($p && packageName($p) =~ /locales-/, $p) } packageDepsId($p);
- if (@deps == 0 || @deps > 0 && (grep { !packageFlagSelected($_) } @deps) == 0) {
- log::l("selecting " . packageName($p) . " by selection on files");
- selectPackage($packages, $p);
- } else {
- log::l("avoid selecting " . packageName($p) . " as its locales language is not already selected");
- }
- }
+ my $pkg = $packages->{depslist}[$id];
+ foreach ($pkg->requires_nosense) {
+ foreach (keys %{$packages->{provides}{$_} || {}}) {
+ if ($id2pkg->{$_}) {
+ push @l2, $_;
+ last;
}
}
}
-
- #- clean memory...
- %installedFilesForUpgrade = ();
-
- #- no need to still use the child as this point, we can let him to terminate.
- close OUTPUT;
- close INPUT;
- waitpid $pid, 0;
- } else {
- close INPUT;
- close OUTPUT;
- open STDIN, "<&INPUT_CHILD";
- open STDOUT, ">&OUTPUT_CHILD";
- exec if_($ENV{LD_LOADER}, $ENV{LD_LOADER}), "parsehdlist", "--interactive", map { "/tmp/$_->{hdlist}" } values %{$packages->{mediums}}
- or c::_exit(1);
- }
-
- #- let the parent known about what we found here!
- foreach my $p (values %{$packages->{names}}) {
- print UPGRADE_OUTPUT "select:" . packageName($p) . "\n" if packageFlagSelected($p);
}
- #- clean false value on toRemove.
- delete $toRemove{''};
-
- #- get filenames that should be saved for packages to remove.
- #- typically config files, but it may broke for packages that
- #- are very old when compabilty has been broken.
- #- but new version may saved to .rpmnew so it not so hard !
- if ($toSave && keys %toRemove) {
- c::rpmdbTraverse($db, sub {
- my ($header) = @_;
- my $otherPackage = (c::headerGetEntry($header, 'name'). '-' .
- c::headerGetEntry($header, 'version'). '-' .
- c::headerGetEntry($header, 'release'));
- if ($toRemove{$otherPackage}) {
- print UPGRADE_OUTPUT "remove:$otherPackage\n";
- if (packageFlagBase($packages->{names}{c::headerGetEntry($header, 'name')})) {
- delete $toRemove{$otherPackage}; #- keep it selected, but force upgrade.
- } else {
- my @files = c::headerGetEntry($header, 'filenames');
- my @flags = c::headerGetEntry($header, 'fileflags');
- for my $i (0..$#flags) {
- if ($flags[$i] & c::RPMFILE_CONFIG()) {
- print UPGRADE_OUTPUT "keepfiles:$files[$i]\n" unless $files[$i] =~ /kdelnk/;
- }
- }
- }
- }
- });
- }
-
- #- close db, job finished !
- c::rpmdbClose($db);
- log::l("done selecting packages to upgrade");
-
- close UPGRADE_OUTPUT;
- c::_exit(0);
+ keys %closure >= $limitMinTrans and last;
}
- #- keep a track of packages that are been selected for being upgraded,
- #- these packages should not be unselected (unless expertise)
- foreach my $p (values %{$packages->{names}}) {
- packageSetFlagUpgrade($p, 1) if packageFlagSelected($p);
- }
+ map { delete $id2pkg->{$_} } grep { $id2pkg->{$_} } keys %closure;
}
-sub allowedToUpgrade { $_[0] !~ /^(kernel|kernel22|kernel2.2|kernel-secure|kernel-smp|kernel-linus|kernel-linus2.2|hackkernel|kernel-enterprise)$/ }
-
sub installCallback {
# my $msg = shift;
# log::l($msg .": ". join(',', @_));
}
sub install($$$;$$) {
- my ($prefix, $isUpgrade, $toInstall, $depOrder, $media) = @_;
+ my ($prefix, $isUpgrade, $toInstall, $packages) = @_;
my %packages;
return if $::g_auto_install || !scalar(@$toInstall);
@@ -1326,65 +1312,26 @@ sub install($$$;$$) {
#- one or many transaction.
my ($total, $nb);
foreach my $pkg (@$toInstall) {
- $packages{packageName($pkg)} = $pkg;
+ $packages{$pkg->id} = $pkg;
$nb++;
- $total += to_int($pkg->[$SIZE_DEPS]); #- do not correct for upgrade!
+ $total += to_int($pkg->size); #- do not correct for upgrade!
}
log::l("pkgs::install $prefix");
- log::l("pkgs::install the following: ", join(" ", keys %packages));
+ log::l("pkgs::install the following: ", join(" ", map { $_->name } values %packages));
eval { fs::mount("/proc", "$prefix/proc", "proc", 0) } unless -e "$prefix/proc/cpuinfo";
init_db($prefix);
- my $callbackOpen = sub {
- my $p = $packages{$_[0]} or log::l("unable to retrieve package of $_[0]"), return -1;
- my $f = packageFile($p);
- print LOG "$f $media->{$p->[$MEDIUM]}{descr}\n";
- my $fd = install_any::getFile($f, $media->{$p->[$MEDIUM]}{descr});
- $fd ? fileno $fd : -1;
- };
- my $callbackClose = sub { packageSetFlagInstalled($packages{$_[0]}, 1) };
-
#- do not modify/translate the message used with installCallback since
#- these are keys during progressing installation, or change in other
#- place (install_steps_gtk.pm,...).
- installCallback("Starting installation", $nb, $total);
+ installCallback($packages, 'user', undef, 'install', $nb, $total);
- my ($i, $min, $medium) = (0, 0, 1);
+ my $medium = 1;
do {
- my @transToInstall;
-
- if (!$depOrder || !$media) {
- @transToInstall = values %packages;
- $nb = 0;
- } else {
- do {
- #- change current media if needed.
- if ($i > $media->{$medium}{max}) {
- #- search for media that contains the desired package to install.
- foreach (keys %$media) {
- $i >= $media->{$_}{min} && $i <= $media->{$_}{max} and $medium = $_, last;
- }
- }
- $i >= $media->{$medium}{min} && $i <= $media->{$medium}{max} or die "unable to find right medium";
- install_any::useMedium($medium);
-
- while ($i <= $media->{$medium}{max} && ($i < $min || scalar @transToInstall < $limitMinTrans)) {
- my $pkg = $depOrder->[$i++] or next;
- my $dep = $packages{packageName($pkg)} or next;
- if ($media->{$dep->[$MEDIUM]}{selected}) {
- push @transToInstall, $dep;
- foreach (map { split '\|' } packageDepsId($dep)) {
- $min < $_ and $min = $_;
- }
- } else {
- log::l("ignoring package $dep->[$FILE] as its medium is not selected");
- }
- --$nb; #- make sure the package is not taken into account as its medium is not selected.
- }
- } while ($nb > 0 && scalar(@transToInstall) == 0); #- avoid null transaction, it a nop that cost a bit.
- }
+ my @transToInstall = installTransactionClosure($packages, \%packages);
+ $nb = values %packages;
#- added to exit typically after last media unselected.
if ($nb == 0 && scalar(@transToInstall) == 0) {
@@ -1395,29 +1342,29 @@ sub install($$$;$$) {
}
#- extract headers for parent as they are used by callback.
- extractHeaders($prefix, \@transToInstall, $media);
+ extractHeaders($prefix, \@transToInstall, $packages->{mediums});
- if ($media->{$medium}{method} eq 'cdrom') {
+ if ($packages->{mediums}{$medium}{method} eq 'cdrom') {
#- extract packages to make sure the getFile below to force
#- accessing medium will not be redirected to updates.
- my @origin = grep { $_->[$MEDIUM] == $medium } @transToInstall;
+ my @origin = grep { packageMedium($packages, $_) == $medium } @transToInstall;
if (@origin) {
#- reset file descriptor open for main process but
#- make sure error trying to change from hdlist are
#- trown from main process too.
- install_any::getFile(packageFile($origin[0]), $media->{$origin[0][$MEDIUM]}{descr});
+ install_any::getFile($origin[0]->filename, packageMedium($packages, $origin[0])->{descr});
- #- allow some log here to check selected status.
- log::l("status for medium $origin[0][$MEDIUM] ($media->{$origin[0][$MEDIUM]}{descr}) is " .
- ($media->{$origin[0][$MEDIUM]}{selected} ? "selected" : "refused"));
+# #- allow some log here to check selected status.
+# log::l("status for medium $origin[0][$MEDIUM] ($media->{$origin[0][$MEDIUM]}{descr}) is " .
+# ($media->{$origin[0][$MEDIUM]}{selected} ? "selected" : "refused"));
}
}
#- and make sure there are no staling open file descriptor too (before forking)!
install_any::getFile('XXX');
- my ($retry_package, $retry_count);
- while ($retry_package || @transToInstall) {
+ my ($retry_pkg, $retry_count);
+ while ($retry_pkg || @transToInstall) {
local (*INPUT, *OUTPUT); pipe INPUT, OUTPUT;
if (my $pid = fork()) {
close OUTPUT;
@@ -1431,9 +1378,11 @@ sub install($$$;$$) {
chomp;
my @params = split ":";
if ($params[0] eq 'close') {
- &$callbackClose($params[1]);
+ my $pkg = $packages->{depslist}[$params[1]];
+ $pkg->set_flag_installed(1);
+ $pkg->set_flag_upgrade(0);
} else {
- installCallback(@params);
+ installCallback($packages, @params);
}
}
}
@@ -1449,56 +1398,48 @@ sub install($$$;$$) {
eval {
close INPUT;
select((select(OUTPUT), $| = 1)[0]);
- $db = c::rpmdbOpen($prefix) or die "error opening RPM database: ", c::rpmErrorString();
- my $trans = c::rpmtransCreateSet($db, $prefix);
- if ($retry_package) {
+ my $db = URPM::DB::open($prefix, 1) or die "error opening RPM database: ", c::rpmErrorString();
+ my $trans = $db->create_transaction($prefix);
+ if ($retry_pkg) {
log::l("opened rpm database for retry transaction of 1 package only");
- c::rpmtransAddPackage($trans, $retry_package->[$HEADER], packageName($retry_package),
- $isUpgrade && allowedToUpgrade(packageName($retry_package)));
+ $trans->add($retry_pkg, $isUpgrade && allowedToUpgrade($retry_pkg->name));
} else {
- log::l("opened rpm database for transaction of ". scalar @transToInstall ." new packages, still $nb after that to do");
- c::rpmtransAddPackage($trans, $_->[$HEADER], packageName($_),
- $isUpgrade && allowedToUpgrade(packageName($_)))
- foreach @transToInstall;
+ log::l("opened rpm database for transaction of ". scalar @transToInstall .
+ " new packages, still $nb after that to do");
+ $trans->add($_, $isUpgrade && allowedToUpgrade($_->name))
+ foreach @transToInstall;
}
- c::rpmdepOrder($trans) or die "error ordering package list: " . c::rpmErrorString();
- c::rpmtransSetScriptFd($trans, fileno LOG);
+ $trans->order or die "error ordering package list: " . c::rpmErrorString();
+ $trans->set_script_fd(fileno LOG);
log::l("rpmRunTransactions start");
- my @probs = c::rpmRunTransactions($trans, $callbackOpen,
- sub { #- callbackClose
- my $p = $packages{$_[0]} or return;
- my $check_installed;
- c::rpmdbNameTraverse($db, packageName($p), sub {
- my ($header) = @_;
- $check_installed ||= c::headerGetEntry($header, 'version') eq packageVersion($p) && c::headerGetEntry($header, 'release') eq packageRelease($p);
- });
- $check_installed and print OUTPUT "close:$_[0]\n"; },
- sub { #- installCallback
- print OUTPUT join(":", @_), "\n"; },
- 1);
+ my @probs = $trans->run($packages, force => 1, nosize => 1, callback_open => sub {
+ my ($data, $type, $id) = @_;
+ my $pkg = defined $id && $data->{depslist}[$id];
+ my $f = $pkg && $pkg->filename;
+ print LOG "$f\n";
+ #my $fd = install_any::getFile($f, $media->{$p->[$MEDIUM]}{descr});
+ my $fd = install_any::getFile($f);
+ $fd ? fileno $fd : -1;
+ }, callback_close => sub {
+ my ($data, $type, $id) = @_;
+ my $pkg = defined $id && $data->{depslist}[$id] or return;
+ my $check_installed;
+ $db->traverse_tag('name', [ $pkg->name ], sub {
+ my ($p) = @_;
+ $check_installed ||= $pkg->compare_pkg($p) == 0;
+ });
+ $check_installed and print OUTPUT "close:$id\n";
+ }, callback_inst => sub {
+ my ($data, $type, $id, $subtype, $amount, $total) = @_;
+ print OUTPUT "$type:$id:$subtype:$amount:$total\n";
+ });
log::l("rpmRunTransactions done, now trying to close still opened fd");
install_any::getFile('XXX'); #- close still opened fd.
- if (@probs) {
- my %parts;
- @probs = reverse grep {
- if (s/(installing package) .* (needs (?:.*) on the (.*) filesystem)/$1 $2/) {
- $parts{$3} ? 0 : ($parts{$3} = 1);
- } else {
- 1;
- }
- } reverse map { s|/mnt||; $_ } @probs;
-
- c::rpmdbClose($db);
- die "installation of rpms failed:\n ", join("\n ", @probs);
- }
+ @probs and die "installation of rpms failed:\n ", join("\n ", @probs);
}; $@ and print OUTPUT "die:$@\n";
-
- c::rpmdbClose($db);
- log::l("rpm database closed");
-
close OUTPUT;
#- now search for child process which may be locking the cdrom, making it unable to be ejected.
@@ -1524,34 +1465,35 @@ sub install($$$;$$) {
#- if we are using a retry mode, this means we have to split the transaction with only
#- one package for each real transaction.
- unless ($retry_package) {
+ unless ($retry_pkg) {
my @badPackages;
foreach (@transToInstall) {
- if (!packageFlagInstalled($_) && $media->{$_->[$MEDIUM]}{selected} && !exists($ignoreBadPkg{packageName($_)})) {
+ if (!$_->flag_installed && packageMedium($packages, $_)->{selected} && !exists($ignoreBadPkg{$_->name})) {
push @badPackages, $_;
- log::l("bad package $_->[$FILE]");
+ log::l("bad package ".$_->fullname);
} else {
- packageFreeHeader($_);
+ $_->free_header;
}
}
@transToInstall = @badPackages;
#- if we are in retry mode, we have to fetch only one package at a time.
- $retry_package = shift @transToInstall;
+ $retry_pkg = shift @transToInstall;
$retry_count = 3;
} else {
- if (!packageFlagInstalled($retry_package) && $media->{$retry_package->[$MEDIUM]}{selected} && !exists($ignoreBadPkg{packageName($retry_package)})) {
+ if (!$retry_pkg->flag_installed && packageMedium($packages, $retry_pkg)->{selected} && !exists($ignoreBadPkg{$retry_pkg->name})) {
if ($retry_count) {
- log::l("retrying installing package $retry_package->[$FILE] alone in a transaction");
+ log::l("retrying installing package ".$retry_pkg->fullname." alone in a transaction");
--$retry_count;
} else {
- log::l("bad package $retry_package->[$FILE] unable to be installed");
- packageSetFlagSelected($retry_package, 0);
- cdie ("error installing package list: $retry_package->[$FILE]");
+ log::l("bad package ". $retry_pkg->fullname ." unable to be installed");
+ $retry_pkg->set_flag_requested(0);
+ $retry_pkg->set_flag_required(0);
+ cdie ("error installing package list: ". $retry_pkg->fullname);
}
}
- if (packageFlagInstalled($retry_package) || ! packageFlagSelected($retry_package)) {
- packageFreeHeader($retry_package);
- $retry_package = shift @transToInstall;
+ if ($retry_pkg->flag_installed || !$retry_pkg->flag_selected) {
+ $retry_pkg->free_header;
+ $retry_pkg = shift @transToInstall;
$retry_count = 3;
}
}
@@ -1596,8 +1538,9 @@ sub remove($$) {
#- do not modify/translate the message used with installCallback since
#- these are keys during progressing installation, or change in other
#- place (install_steps_gtk.pm,...).
- installCallback("Starting removing other packages", scalar @$toRemove);
+ installCallback($db, 'user', undef, 'remove', scalar @$toRemove);
+ #- TODO
if (my @probs = c::rpmRunTransactions($trans, $callbackOpen, $callbackClose, \&installCallback, 1)) {
die "removing of old rpms failed:\n ", join("\n ", @probs);
}
@@ -1611,48 +1554,54 @@ sub remove($$) {
sub selected_leaves {
my ($packages) = @_;
- my %l;
+ my @leaves;
- #- initialize l with all id, not couting base package.
- foreach my $id (0 .. $#{$packages->{depslist}}) {
- my $pkg = packageById($packages, $id) or next;
- packageSelectedOrInstalled($pkg) && !packageFlagBase($pkg) or next;
- $l{$id} = 1;
+ foreach (@{$packages->{depslist}}) {
+ $_->flag_requested && !$_->flag_base and push @leaves, $_->name;
}
-
- foreach my $id (keys %l) {
- #- when a package is in a choice, increase its value in hash l, because
- #- it has to be examined before when we will select them later.
- #- NB: this number may be computed before to save time.
- my $p = $packages->{depslist}[$id] or next;
- foreach (packageDepsId($p)) {
- if (/\|/) {
- foreach (split '\|') {
- exists $l{$_} or next;
- $l{$_} > 1 + $l{$id} or $l{$_} = 1 + $l{$id};
- }
- }
- }
- }
-
- #- at this level, we can remove selected packages that are already
- #- required by other, but we have to sort according to choice usage.
- foreach my $id (sort { $l{$b} <=> $l{$a} || $b <=> $a } keys %l) {
- #- do not count already deleted id, else cycles will be removed.
- $l{$id} or next;
-
- my $p = $packages->{depslist}[$id] or next;
- foreach (packageDepsId($p)) {
- #- choices need no more to be examined, this has been done above.
- /\|/ and next;
- #- improve value of this one, so it will be selected before.
- $l{$id} < $l{$_} and $l{$id} = $l{$_};
- $l{$_} = 0;
- }
- }
-
- #- now sort again according to decrementing value, and gives packages name.
- [ map { packageName($packages->{depslist}[$_]) } sort { $l{$b} <=> $l{$a} } grep { $l{$_} > 0 } keys %l ];
+# my %l;
+#
+# #- initialize l with all id, not couting base package.
+# foreach my $id (0 .. $#{$packages->{depslist}}) {
+# my $pkg = packageById($packages, $id) or next;
+# packageSelectedOrInstalled($pkg) && !$pkg->flag_base or next;
+# $l{$id} = 1;
+# }
+#
+# foreach my $id (keys %l) {
+# #- when a package is in a choice, increase its value in hash l, because
+# #- it has to be examined before when we will select them later.
+# #- NB: this number may be computed before to save time.
+# my $p = $packages->{depslist}[$id] or next;
+# foreach (packageDepsId($p)) {
+# if (/\|/) {
+# foreach (split '\|') {
+# exists $l{$_} or next;
+# $l{$_} > 1 + $l{$id} or $l{$_} = 1 + $l{$id};
+# }
+# }
+# }
+# }
+#
+# #- at this level, we can remove selected packages that are already
+# #- required by other, but we have to sort according to choice usage.
+# foreach my $id (sort { $l{$b} <=> $l{$a} || $b <=> $a } keys %l) {
+# #- do not count already deleted id, else cycles will be removed.
+# $l{$id} or next;
+#
+# my $p = $packages->{depslist}[$id] or next;
+# foreach (packageDepsId($p)) {
+# #- choices need no more to be examined, this has been done above.
+# /\|/ and next;
+# #- improve value of this one, so it will be selected before.
+# $l{$id} < $l{$_} and $l{$id} = $l{$_};
+# $l{$_} = 0;
+# }
+# }
+#
+# #- now sort again according to decrementing value, and gives packages name.
+# [ map { packageName($packages->{depslist}[$_]) } sort { $l{$b} <=> $l{$a} } grep { $l{$_} > 0 } keys %l ];
+ \@leaves;
}
@@ -1723,7 +1672,7 @@ ucd-snmp
grep {
my $p = packageByName($packages, $_);
- $p && packageFlagSelected($p);
+ $p && $p->flag_selected;
} @naughtyServers;
}
diff --git a/perl-install/share/list b/perl-install/share/list
index c2c78823c..4f5ecc6c2 100644
--- a/perl-install/share/list
+++ b/perl-install/share/list
@@ -115,6 +115,9 @@
/usr/lib/perl5/vendor_perl/PERL_VERSION/MDK/Common/System.pm
/usr/lib/perl5/vendor_perl/PERL_VERSION/MDK/Common/Various.pm
/usr/lib/perl5/vendor_perl/PERL_VERSION/MDK/Common.pm
+/usr/lib/perl5/vendor_perl/PERL_VERSION/ARCH-linux/URPM.pm
+/usr/lib/perl5/vendor_perl/PERL_VERSION/ARCH-linux/URPM/Resolve.pm
+/usr/lib/perl5/vendor_perl/PERL_VERSION/ARCH-linux/auto/URPM/URPM.so
/usr/lib/perl5/vendor_perl/PERL_VERSION/ARCH-linux/packdrake.pm
/usr/lib/perl5/vendor_perl/PERL_VERSION/ARCH-linux/Gtk.pm
/usr/lib/perl5/vendor_perl/PERL_VERSION/ARCH-linux/Gtk/Types.pm