1230 lines
33 KiB
Perl
Executable File
1230 lines
33 KiB
Perl
Executable File
#!/usr/bin/perl -w
|
|
#
|
|
# Copyright 1999 Raphaël Hertzog <hertzog@debian.org>
|
|
# Copyright 2006-2016 Steve McIntyre <93sam@debian.org>
|
|
# See the README file for the license
|
|
#
|
|
# This script takes 1 argument on input :
|
|
# - a filename listing all the packages to include
|
|
#
|
|
# and it sorts those packages such that dependencies are met in order
|
|
#
|
|
# Used to be called list2cds, renamed as it now just sorts
|
|
# dependencies. Later code in make_disc_trees.pl actually splits on a
|
|
# per-disc basis now.
|
|
|
|
use strict;
|
|
use Data::Dumper;
|
|
use Dpkg::Version;
|
|
|
|
my $listfile = shift;
|
|
|
|
my $nonfree = read_env('NONFREE', 0);
|
|
my $extranonfree = read_env('EXTRANONFREE', 0);
|
|
my $force_firmware = read_env('FORCE_FIRMWARE', 0);
|
|
my $local = read_env('LOCAL', 0);
|
|
my $complete = read_env('COMPLETE', 0);
|
|
my $add_rec = ! read_env('NORECOMMENDS', 1);
|
|
my $add_sug = ! read_env('NOSUGGESTS', 1);
|
|
my $verbose = read_env('VERBOSE', 0);
|
|
my $max_pkg_size = read_env('MAX_PKG_SIZE', 9999999999999);
|
|
my $codename = $ENV{'CODENAME'};
|
|
my $backports_list = read_env('BACKPORTS', "");
|
|
my $backports = 1;
|
|
if ($backports_list =~ /^$/) {
|
|
$backports = 0;
|
|
}
|
|
|
|
my $apt = "$ENV{'BASEDIR'}/tools/apt-selection";
|
|
my $adir = "$ENV{'APTTMP'}/$ENV{'CODENAME'}-$ENV{'ARCH'}";
|
|
my $arch = "$ENV{'ARCH'}";
|
|
my $dir = "$ENV{'TDIR'}/$ENV{'CODENAME'}";
|
|
|
|
my $force_unstable_tasks = read_env('FORCE_SID_TASKSEL', 0);
|
|
my $tasks_packages = read_env('TASKS_PACKAGES',
|
|
"$ENV{'MIRROR'}/dists/sid/main/binary-$ENV{'ARCH'}/Packages.gz");
|
|
my @output = ();
|
|
|
|
$| = 1; # Autoflush for debugging
|
|
|
|
open(LOG, ">$dir/sort_deps.$arch.log")
|
|
|| die "Can't write in $dir/sort_deps.$arch.log !\n";
|
|
|
|
sub read_env {
|
|
my $env_var = shift;
|
|
my $default = shift;
|
|
|
|
if (exists($ENV{$env_var})) {
|
|
return $ENV{$env_var};
|
|
}
|
|
# else
|
|
return $default;
|
|
}
|
|
|
|
sub msg {
|
|
my $level = shift;
|
|
if ($verbose >= $level) {
|
|
print @_;
|
|
}
|
|
print LOG @_;
|
|
}
|
|
|
|
my %included;
|
|
my %excluded;
|
|
my %packages;
|
|
my %backport_packages;
|
|
|
|
msg(0, "Running sort_deps to sort packages for $arch:\n");
|
|
msg(1, "======================================================================
|
|
Here are the settings you've chosen for making the list:
|
|
Architecture: $arch
|
|
List of prefered packages: $listfile
|
|
Output file: $dir/packages.$arch
|
|
");
|
|
msg(1, "Complete selected packages with all the rest: ");
|
|
msg(1, yesno($complete)."\n");
|
|
msg(1, "Include non-free packages: ");
|
|
msg(1, yesno($nonfree)."\n");
|
|
msg(1, "Force inclusion of firmware packages: ");
|
|
msg(1, yesno($force_firmware)."\n");
|
|
msg(1, "Include Recommends: ");
|
|
msg(1, yesno($add_rec)."\n");
|
|
msg(1, "Include Suggests: ");
|
|
msg(1, yesno($add_sug)."\n");
|
|
msg(1, "Maximum allowed package size: $max_pkg_size bytes\n");
|
|
msg(1, "======================================================================
|
|
");
|
|
|
|
# Get the information on all packages
|
|
my $oldrs = $/;
|
|
$/ = '';
|
|
msg(1, "Parsing packages...\n");
|
|
open(AVAIL, "$apt cache dumpavail |") || die "Can't fork : $!\n";
|
|
my ($p, $re);
|
|
my $num_pkgs = 0;
|
|
while (defined($_=<AVAIL>)) {
|
|
next if not m/^Package: (\S+)\s*$/m;
|
|
if (!$force_unstable_tasks || $1 !~ /^task-/) {
|
|
parse_package(0, $_);
|
|
$num_pkgs++;
|
|
}
|
|
}
|
|
msg(1, "Got $num_pkgs packages\n");
|
|
close AVAIL or die "apt-cache failed : $@ ($!)\n";
|
|
if ($backports) {
|
|
$num_pkgs = 0;
|
|
msg(1, "Parsing packages from backports...\n");
|
|
open(AVAIL, "USE_BP=1 $apt cache dumpavail |") || die "Can't fork : $!\n";
|
|
my ($p, $re);
|
|
while (defined($_=<AVAIL>)) {
|
|
next if not m/^Package: (\S+)\s*$/m;
|
|
if (!$force_unstable_tasks || $1 !~ /^task-/) {
|
|
parse_package(1, $_);
|
|
$num_pkgs++;
|
|
}
|
|
}
|
|
msg(1, "Got $num_pkgs packages\n");
|
|
close AVAIL or die "apt-cache (backports) failed : $@ ($!)\n";
|
|
}
|
|
|
|
# Read in the extra (new/unstable) tasks packages
|
|
if ($force_unstable_tasks) {
|
|
my $num = 0;
|
|
if ($tasks_packages =~ /\.gz$/) {
|
|
open(AVAIL, "zcat $tasks_packages |") || die "Can't zcat $tasks_packages : $!\n";
|
|
} else {
|
|
open(AVAIL, "< $tasks_packages") || die "Can't open $tasks_packages for reading: $!\n";
|
|
}
|
|
while (defined($_=<AVAIL>)) {
|
|
next if not m/^Package: (\S+)\s*$/m;
|
|
if ($1 =~ /^task-/) {
|
|
parse_package(0, $_);
|
|
$num++;
|
|
}
|
|
}
|
|
close AVAIL or die "reading unstable tasks failed : $@ ($!)\n";
|
|
msg(0, " Read $num tasks packages from $tasks_packages\n");
|
|
}
|
|
|
|
$/ = $oldrs;
|
|
|
|
# Get the list of excluded packages
|
|
%excluded = %included;
|
|
my $count_excl = 0;
|
|
|
|
# Now exclude packages because of the non-free rules
|
|
if (not $nonfree) {
|
|
foreach (grep { $packages{$_}{"Section"} =~ /non-free/ }
|
|
(keys %packages)) {
|
|
if ($force_firmware and $packages{$_}{"IsFirmware"}) {
|
|
msg(1, "force_firmware: keeping non-free package $_\n");
|
|
} else {
|
|
$excluded{$_} = 'nonfree';
|
|
$count_excl++;
|
|
}
|
|
}
|
|
}
|
|
|
|
msg(1, "Statistics:
|
|
Number of packages: @{ [scalar(keys %packages)] }
|
|
Number of excluded: $count_excl of @{ [scalar(keys %excluded)] }
|
|
======================================================================
|
|
|
|
");
|
|
|
|
open(STATS, "> $dir/stats.excluded.$arch")
|
|
|| die "Can't write in stats.excluded.$arch: $!\n";
|
|
foreach (keys %excluded) {
|
|
print STATS "$_ => $excluded{$_}\n";
|
|
}
|
|
close (STATS);
|
|
|
|
# Browse the list of packages to include
|
|
my ($output_size, $size) = (0, 0);
|
|
my %cds;
|
|
|
|
# Generate a dependency tree for each package
|
|
msg(0, " Generating dependency tree with apt-cache depends...\n");
|
|
my (@list) = grep (!/\/$codename-backports$/, keys %packages);
|
|
while (@list) {
|
|
my (@pkg) = splice(@list,0,200);
|
|
$ENV{'LC_ALL'} = 'C'; # Required since apt is now translated
|
|
open (APT, "$apt cache depends @pkg |") || die "Can't fork : $!\n";
|
|
my (@res) = (<APT>);
|
|
close APT or die "'apt-cache depends failed: $! \n";
|
|
# Getting rid of conflicts/replaces/provides
|
|
my $i = 0;
|
|
my $nb_lines = scalar @res;
|
|
push @res, ""; # Avoid warnings ...
|
|
while ($i < $nb_lines) {
|
|
if ($res[$i] !~ m/^(\S+)\s*$/) {
|
|
msg(0, "UNEXPECTED: Line `$res[$i]' while parsing " .
|
|
"end of deptree from '$p'\n");
|
|
die "sort_deps failed! :-(\n";
|
|
}
|
|
$p = lc $1;
|
|
$i++;
|
|
msg(2, " Dependency tree of `$p' ...\n");
|
|
read_depends (\$i, \@res, $p);
|
|
}
|
|
|
|
}
|
|
# Now redo with backports packages
|
|
if ($backports) {
|
|
@list = grep (/\/$codename-backports$/, keys %packages);
|
|
while (@list) {
|
|
my (@pkg) = splice(@list,0,200);
|
|
$ENV{'LC_ALL'} = 'C'; # Required since apt is now translated
|
|
open (APT, "USE_BP=1 $apt cache depends @pkg |") || die "Can't fork : $!\n";
|
|
my (@res) = (<APT>);
|
|
close APT or die "'apt-cache depends failed: $! \n";
|
|
# Getting rid of conflicts/replaces/provides
|
|
my $i = 0;
|
|
my $nb_lines = scalar @res;
|
|
push @res, ""; # Avoid warnings ...
|
|
while ($i < $nb_lines) {
|
|
if ($res[$i] !~ m/^(\S+)\s*$/) {
|
|
msg(0, "UNEXPECTED: Line `$res[$i]' while parsing " .
|
|
"end of deptree from '$p'\n");
|
|
die "sort_deps failed! :-(\n";
|
|
}
|
|
$p = lc $1;
|
|
$i++;
|
|
msg(2, " Dependency tree of `$p/$codename-backports' ...\n");
|
|
read_depends (\$i, \@res, "$p/$codename-backports");
|
|
}
|
|
}
|
|
# Now check and maybe up our dependencies in the backports
|
|
# packages. If any of them depend on package versions not already
|
|
# in the base set, change them to be package/$codename-backports
|
|
# instead. Only need to check direct dependencies here; any
|
|
# indirects going through base packages shouldn't have any
|
|
# backports dependencies, of course. Can only do this once we've
|
|
# read *all* the packages in.
|
|
@list = grep (/\/$codename-backports$/, keys %packages);
|
|
foreach my $pkg (@list) {
|
|
msg(1, "Fixing up deps for $pkg\n");
|
|
$packages{$pkg}{"Depends"} = fix_backport_depends($packages{$pkg}{"Depends"});
|
|
$packages{$pkg}{"Recommends"} = fix_backport_depends($packages{$pkg}{"Recommends"});
|
|
$packages{$pkg}{"Suggests"} = fix_backport_depends($packages{$pkg}{"Suggests"});
|
|
}
|
|
}
|
|
|
|
msg(0, " Adding standard, required, important and base packages first\n");
|
|
# Automatically include packages listed in the status file
|
|
open(STATUS, "< $adir/status") || die "Can't open status file $adir/status: $!\n";
|
|
while (defined($_ = <STATUS>)) {
|
|
next if not m/^Package: (\S+)/;
|
|
$p = $1;
|
|
if (not exists $packages{$p}) {
|
|
msg(1, "WARNING: Package `$p' is listed in the status file "
|
|
. "but doesn't exist ! (ignored) \n",
|
|
" TIP: Try to generate the status file with " .
|
|
"make (correct)status (after a make distclean)...\n");
|
|
next;
|
|
}
|
|
next if $excluded{$p};
|
|
if ($p =~ /\/$codename-backports$/) {
|
|
add_package($p, 1);
|
|
} else {
|
|
add_package($p, 0);
|
|
}
|
|
}
|
|
close STATUS;
|
|
msg(0, " S/R/I/B packages take $output_size bytes\n");
|
|
|
|
# Now start to look for packages wanted by the user ...
|
|
msg(0, " Adding the rest of the requested packages\n");
|
|
open (LIST, "< $listfile") || die "Can't open $listfile : $!\n";
|
|
while (defined($_=<LIST>)) {
|
|
chomp;
|
|
msg(1, "Looking at list, line \"$_\"\n");
|
|
next if m/^\s*$/;
|
|
if (not exists $packages{$_}) {
|
|
msg(1, "WARNING: '$_' does not appear to be available ... " .
|
|
"(ignored)\n");
|
|
next;
|
|
}
|
|
next if $excluded{$_};
|
|
if ($included{$_}) {
|
|
msg(3, "$_ has already been included.\n");
|
|
next;
|
|
}
|
|
# This is because udebs tend to have bad dependencies but work
|
|
# nevertheless ... this may be removed once the udebs have a
|
|
# better depencency system
|
|
if ($packages{$_}{"IsUdeb"}) {
|
|
add_to_output($_);
|
|
} else {
|
|
if ($_ =~ /\/$codename-backports$/) {
|
|
add_package($_, 1);
|
|
} else {
|
|
add_package($_, 0);
|
|
}
|
|
}
|
|
}
|
|
close LIST;
|
|
|
|
msg(0, " Now up to $output_size bytes\n");
|
|
# All requested packages have been included
|
|
# But we'll continue to add if $complete was requested
|
|
if ($complete) {
|
|
msg(0, " COMPLETE=1; add all remaining packages\n");
|
|
# Try to sort them by section even if packages from
|
|
# other sections will get in through dependencies
|
|
# With some luck, most of them will already be here
|
|
foreach my $p (sort { ($packages{lc $a}{"Section"} cmp $packages{lc $b}{"Section"})
|
|
|| (lc $a cmp lc $b) }
|
|
grep { not ($included{$_} or $excluded{$_}) } keys %packages) {
|
|
# At this point, we should *not* be adding any more udebs,
|
|
# as they're no use to anybody.
|
|
if ($packages{lc $p}{"IsUdeb"}) {
|
|
msg(2, " Ignoring udeb $p ...\n");
|
|
} else {
|
|
if ($p =~ /\/$codename-backports$/i) {
|
|
add_package (lc $p, 1);
|
|
} else {
|
|
add_package (lc $p, 0);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# Now select the non-free packages for an extra CD
|
|
if ($extranonfree and (! $nonfree))
|
|
{
|
|
my ($p, @toinclude);
|
|
|
|
msg(0, " Adding non-free packages now\n");
|
|
|
|
# Finally accept non-free packages ...
|
|
foreach $p (grep { $excluded{$_} eq "nonfree" } (keys %excluded))
|
|
{
|
|
$excluded{$p} = 0;
|
|
push @toinclude, $p;
|
|
}
|
|
|
|
# Include non-free packages
|
|
foreach $p (@toinclude)
|
|
{
|
|
if ($p =~ /\/$codename-backports$/i) {
|
|
add_package (lc $p, 1);
|
|
} else {
|
|
add_package (lc $p, 0);
|
|
}
|
|
}
|
|
|
|
# If a contrib package was listed in the list of packages to
|
|
# include and if COMPLETE=0 there's a chance that the package
|
|
# will not get included in any CD ... so I'm checking the complete
|
|
# list again
|
|
open (LIST, "< $listfile") || die "Can't open $listfile : $!\n";
|
|
while (defined($_=<LIST>)) {
|
|
chomp;
|
|
next if m/^\s*$/;
|
|
next if $included{$_};
|
|
next if $included{lc $_};
|
|
next if $excluded{$_};
|
|
next if $excluded{lc $_};
|
|
if (not exists $packages{$_} && not exists $packages{lc $_}) {
|
|
msg(1, "WARNING: '$_' does not appear to be available ... " .
|
|
"(ignored)\n");
|
|
next;
|
|
}
|
|
if ($packages{lc $p}{"IsUdeb"}) {
|
|
msg(2, " Ignoring udeb $p ...\n");
|
|
} else {
|
|
if ($_ =~ /\/$codename-backports$/i) {
|
|
add_package (lc $_, 1);
|
|
} else {
|
|
add_package (lc $_, 0);
|
|
}
|
|
}
|
|
}
|
|
close LIST;
|
|
|
|
# Try to include other packages that could not be included
|
|
# before (because they depends on excluded non-free packages)
|
|
if ($complete)
|
|
{
|
|
foreach $p (sort { ($packages{$a}{"Section"}
|
|
cmp $packages{$b}{"Section"}) || ($a cmp $b) }
|
|
grep { not ($included{$_} or $excluded{$_}) }
|
|
keys %packages)
|
|
{
|
|
if ($packages{lc $p}{"IsUdeb"}) {
|
|
msg(2, " Ignoring udeb $p ...\n");
|
|
} else {
|
|
if ($p =~ /\/$codename-backports$/i) {
|
|
add_package (lc $p, 1);
|
|
} else {
|
|
add_package (lc $p, 0);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
# Remove old files
|
|
foreach (glob("$dir/*.packages*")) {
|
|
unlink $_;
|
|
}
|
|
|
|
# Now write the list down
|
|
my $count = 0;
|
|
open(CDLIST, "> $dir/packages.$arch")
|
|
|| die "Can't write in $dir/$_.packages.$arch: $!\n";
|
|
open(FWLIST, ">> $dir/firmware-packages")
|
|
|| die "Can't write in $dir/firmware-packages: $!\n";
|
|
foreach (@output) {
|
|
my $component = $packages{$_}{"Component"};
|
|
my $size = $packages{$_}{"Size"};
|
|
my $bu = $packages{$_}{"Built-Using"};
|
|
print CDLIST "$arch:$component:$_:$size:$bu\n";
|
|
if ($packages{$_}{"IsFirmware"}) {
|
|
print FWLIST "$_\n";
|
|
}
|
|
$count++;
|
|
}
|
|
close CDLIST;
|
|
close FWLIST;
|
|
msg(0, "Done: processed/sorted $count packages, total size $output_size bytes.\n");
|
|
|
|
close LOG;
|
|
|
|
## END OF MAIN
|
|
## BEGINNING OF SUBS
|
|
|
|
sub parse_package {
|
|
my $p;
|
|
my $use_bp = shift;
|
|
m/^Package: (\S+)\s*$/m and $p = $1;
|
|
if ($use_bp) {
|
|
$p = "$p/$codename-backports";
|
|
}
|
|
$included{$p} = 0;
|
|
$packages{$p}{"Package"} = $p;
|
|
foreach $re (qw(Version Priority Section Filename Size MD5sum)) {
|
|
(m/^$re: (\S+)\s*$/m and $packages{$p}{$re} = $1)
|
|
|| msg(1, "Header field '$re' missing for package '$p'.\n");
|
|
}
|
|
$packages{$p}{"Depends"} = [];
|
|
$packages{$p}{"Suggests"} = [];
|
|
$packages{$p}{"Recommends"} = [];
|
|
$packages{$p}{"Built-Using"} = "";
|
|
if (m/^Built-Using: (.*)$/m) {
|
|
my $built = $1;
|
|
$built =~ s/ \(= \S*\)//g;
|
|
$built =~ s/,//g;
|
|
$built =~ s/ /,/g;
|
|
$packages{$p}{"Built-Using"} = $built;
|
|
}
|
|
$packages{$p}{"IsUdeb"} = ($packages{$p}{"Filename"} =~ /.udeb$/) ? 1 : 0;
|
|
$packages{$p}{"IsFirmware"} = ($packages{$p}{"Filename"} =~ /(firmware|microcode)/) ? 1 : 0;
|
|
if ($packages{$p}{"Section"} =~ /contrib\//) {
|
|
$packages{$p}{"Component"} = "contrib";
|
|
} elsif ($packages{$p}{"Section"} =~ /non-free\//) {
|
|
$packages{$p}{"Component"} = "non-free";
|
|
} elsif ($packages{$p}{"IsUdeb"}) {
|
|
$packages{$p}{"Component"} = "main-installer";
|
|
} else {
|
|
$packages{$p}{"Component"} = "main";
|
|
}
|
|
}
|
|
|
|
sub dump_depend {
|
|
my $tmpin = shift;
|
|
my %d;
|
|
my $ret = "";
|
|
|
|
if ("ARRAY" eq ref($tmpin)) {
|
|
my @array = @{$tmpin};
|
|
foreach (@array) {
|
|
%d = %$_;
|
|
$ret .= $d{"Package"};
|
|
if ($d{"CmpOp"} ne "") {
|
|
$ret .= " (" . $d{"CmpOp"} . " " . $d{"Version"} . ")";
|
|
}
|
|
$ret .= " ";
|
|
}
|
|
} elsif ("HASH" eq ref($tmpin)) {
|
|
%d = %$tmpin;
|
|
$ret .= $d{"Package"};
|
|
if ($d{"CmpOp"} ne "") {
|
|
$ret .= " (" . $d{"CmpOp"} . " " . $d{"Version"} . ")";
|
|
}
|
|
} else {
|
|
die "dump_depend: $tmpin is neither an array nor a hash!\n";
|
|
}
|
|
|
|
return $ret;
|
|
}
|
|
|
|
sub dump_or_list {
|
|
my $out_type = shift;
|
|
my $elt = shift;
|
|
my @or = @$elt;
|
|
|
|
if (scalar @or == 1) {
|
|
msg(1, " $out_type: " . dump_depend($or[0]) . "\n");
|
|
} else {
|
|
msg(1, " $out_type: OR (");
|
|
foreach my $t (@or) {
|
|
msg(1, dump_depend($t) . " ");
|
|
}
|
|
msg(1, ")\n");
|
|
}
|
|
}
|
|
|
|
sub read_depends {
|
|
my $i = shift; # Ref
|
|
my $lines = shift; # Ref
|
|
my $pkg = shift; # string
|
|
my $types = "(?:Pre)?Depends|Suggests|Recommends|Replaces|Conflicts|Breaks|Enhances";
|
|
my (@dep, @rec, @sug);
|
|
my ($type, $or);
|
|
|
|
while ($lines->[$$i] =~ m/^\s([\s\|])($types):/) {
|
|
$type = $2; $or = $1;
|
|
# Get rid of replaces, conflicts and any other fields we don't
|
|
# care about...
|
|
if (($type eq "Replaces") or
|
|
($type eq "Conflicts") or
|
|
($type eq "Breaks") or
|
|
($type eq "Enhances")) {
|
|
$$i++;
|
|
while ($lines->[$$i] =~ m/^\s{4}/) {
|
|
$$i++;
|
|
}
|
|
next;
|
|
}
|
|
|
|
my $out_type = $type;
|
|
$out_type =~ s/^Pre//; # PreDepends are like Depends for me
|
|
|
|
# Check the kind of depends : or, virtual, normal
|
|
if ($or eq '|') {
|
|
my $elt = read_ordepends ($i, $lines);
|
|
dump_or_list($out_type, \@$elt);
|
|
push @{$packages{$pkg}{$out_type}}, $elt;
|
|
} elsif ($lines->[$$i] =~ m/^\s\s$type: <([^>]+)>/) {
|
|
my $elt = read_virtualdepends ($i, $lines);
|
|
foreach my $t (@$elt) {
|
|
msg(1, " $out_type: " . dump_depend($t) . " <virt>\n");
|
|
}
|
|
push @{$packages{$pkg}{$out_type}}, $elt;
|
|
} elsif ($lines->[$$i] =~ m/^\s\s$type: (\S+)( \((\S+) (\S+)\))*/) {
|
|
my @or;
|
|
my %elt;
|
|
$elt{"Package"} = $1;
|
|
if (defined $2) {
|
|
$elt{"CmpOp"} = $3;
|
|
$elt{"Version"} = $4;
|
|
} else {
|
|
$elt{"CmpOp"} = "";
|
|
$elt{"Version"} = "";
|
|
}
|
|
push @or, \%elt;
|
|
$$i++;
|
|
|
|
# Special case for packages providing not
|
|
# truly virtual packages
|
|
if ($lines->[$$i] =~ m/^\s{4}/) {
|
|
while ($lines->[$$i] =~ m/\s{4}(\S+)( \((\S+) (\S+)\))*/) {
|
|
my %elt1;
|
|
$elt1{"Package"} = $1;
|
|
if (defined $2) {
|
|
$elt1{"CmpOp"} = $3;
|
|
$elt1{"Version"} = $4;
|
|
} else {
|
|
$elt1{"CmpOp"} = "";
|
|
$elt1{"Version"} = "";
|
|
}
|
|
push @or, \%elt1;
|
|
$$i++;
|
|
}
|
|
}
|
|
dump_or_list($out_type, \@or);
|
|
push @{$packages{$pkg}{$out_type}}, \@or;
|
|
} else {
|
|
msg(0, "ERROR: Unknown depends line : $lines->[$$i]\n");
|
|
foreach ($$i - 3 .. $$i + 3) {
|
|
msg(0, " ", $lines->[$_]);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# Big matrix of tests. Check to see if the available version of a
|
|
# package matches what we're requesting in a dependency relationship
|
|
sub check_versions {
|
|
my $wanted = shift;
|
|
my $op = shift;
|
|
my $available = shift;
|
|
|
|
# Trivial check - if we don't care about versioning, anything will
|
|
# do!
|
|
if ($op eq "") {
|
|
return 1;
|
|
}
|
|
|
|
# Ask the dpkg perl code to compare the version strings
|
|
my $comp = version_compare($available, $wanted);
|
|
|
|
if ($op eq "<=") {
|
|
if ($comp == -1 || $comp == 0) {
|
|
return 1;
|
|
}
|
|
} elsif ($op eq ">=") {
|
|
if ($comp == 0 || $comp == 1) {
|
|
return 1;
|
|
}
|
|
} elsif ($op eq "<<") {
|
|
if ($comp == -1) {
|
|
return 1;
|
|
}
|
|
} elsif ($op eq ">>") {
|
|
if ($comp == 1) {
|
|
return 1;
|
|
}
|
|
} elsif ($op eq "=") {
|
|
if ($comp == 0) {
|
|
return 1;
|
|
}
|
|
# Not sure this ("!") actually exists!
|
|
# Mentioned in apt sources, but not in debian policy
|
|
# No harm done by checking for it, though...
|
|
} elsif ($op eq "!") {
|
|
if ($comp == -1 || $comp == 1) {
|
|
return 1;
|
|
}
|
|
}
|
|
# else
|
|
return 0;
|
|
}
|
|
|
|
# Check if a specific dependency package is installed already
|
|
sub dep_pkg_included {
|
|
my $p = shift;
|
|
my $check_backports = shift;
|
|
my $need_udeb = shift;
|
|
my %d = %$p;
|
|
my $pn = $d{"Package"};
|
|
|
|
if ($included{$pn}) {
|
|
if (check_versions($d{"Version"}, $d{"CmpOp"}, $packages{$pn}{"Version"})) {
|
|
if ($packages{$pn}{"IsUdeb"} == $need_udeb) {
|
|
msg(1, " $pn is included already, acceptable version " . $packages{$pn}{"Version"} . "\n");
|
|
return 1;
|
|
} else {
|
|
my $explanation = "it's a udeb instead of regular deb";
|
|
$explanation = "it's a deb instead of an udeb" if $need_udeb;
|
|
msg(1, " $pn is included already, but $explanation\n");
|
|
}
|
|
} else {
|
|
msg(1, " $pn is included already, but invalid version " . $packages{$pn}{"Version"} . "\n");
|
|
}
|
|
}
|
|
msg(1, " $pn not included in a useful version, check_backports $check_backports\n");
|
|
if ($check_backports) {
|
|
$pn = "$pn/$codename-backports";
|
|
msg(1, " Checking $pn too:\n");
|
|
if ($included{$pn}) {
|
|
if (check_versions($d{"Version"}, $d{"CmpOp"}, $packages{$pn}{"Version"})) {
|
|
if ($packages{$pn}{"IsUdeb"} == $need_udeb) {
|
|
msg(1, " $pn is included already, acceptable version " . $packages{$pn}{"Version"} . "\n");
|
|
return 1;
|
|
} else {
|
|
my $explanation = "it's a udeb instead of regular deb";
|
|
$explanation = "it's a deb instead of an udeb" if $need_udeb;
|
|
msg(1, " $pn is included already, but $explanation\n");
|
|
}
|
|
} else {
|
|
msg(1, " $pn is included already, but invalid version " . $packages{$pn}{"Version"} . "\n");
|
|
}
|
|
msg(1, " $pn not included in a useful version\n");
|
|
}
|
|
}
|
|
# else
|
|
return 0;
|
|
}
|
|
|
|
# Check backports package dependencies; update them if they are also only in backports
|
|
sub fix_backport_depends {
|
|
my $deplist = shift;
|
|
my @new_dep_list;
|
|
foreach my $thisdep (@{$deplist}) {
|
|
if ("ARRAY" eq ref($thisdep)) {
|
|
# If it's an OR list
|
|
my @new_or_list;
|
|
foreach my $pkg (@{$thisdep}) {
|
|
my %t = %$pkg;
|
|
my $pkgname = lc $t{"Package"};
|
|
# Does the package exist?
|
|
if (exists $excluded{$pkgname} &&
|
|
check_versions($t{"Version"}, $t{"CmpOp"}, $packages{$pkgname}{"Version"})) {
|
|
# Looks fine already
|
|
push (@new_or_list, $pkg);
|
|
next;
|
|
}
|
|
# Doesn't exist, or version doesn't work. Try backports
|
|
$pkgname = "$pkgname/$codename-backports";
|
|
if (exists $excluded{$pkgname} &&
|
|
check_versions($t{"Version"}, $t{"CmpOp"}, $packages{$pkgname}{"Version"})) {
|
|
my %elt;
|
|
$elt{"Package"} = $pkgname;
|
|
$elt{"CmpOp"} = $t{"CmpOp"};
|
|
$elt{"Version"} = $t{"Version"};
|
|
push @new_or_list, \%elt;
|
|
msg(1, " Upgrading dep to $pkgname\n");
|
|
next;
|
|
}
|
|
}
|
|
push (@new_dep_list, \@new_or_list);
|
|
} else {
|
|
# It's virtual or a normal package
|
|
my %t = %{$thisdep};
|
|
my $pkgname = lc $t{"Package"};
|
|
# Does the package exist?
|
|
if (exists $excluded{$pkgname} &&
|
|
check_versions($t{"Version"}, $t{"CmpOp"}, $packages{$pkgname}{"Version"})) {
|
|
# Looks fine already
|
|
push (@new_dep_list, $thisdep);
|
|
next;
|
|
}
|
|
# Doesn't exist, or version doesn't work. Try backports
|
|
$pkgname = "$pkgname/$codename-backports";
|
|
if (exists $excluded{$pkgname} &&
|
|
check_versions($t{"Version"}, $t{"CmpOp"}, $packages{$pkgname}{"Version"})) {
|
|
my %elt;
|
|
$elt{"Package"} = $pkgname;
|
|
$elt{"CmpOp"} = $t{"CmpOp"};
|
|
$elt{"Version"} = $t{"Version"};
|
|
push @new_dep_list, \%elt;
|
|
msg(1, " Upgrading dep to $pkgname\n");
|
|
next;
|
|
}
|
|
}
|
|
}
|
|
return \@new_dep_list;
|
|
}
|
|
|
|
# Check to see if a dependency is satisfied, either a direct
|
|
# dependency or any one of an OR array
|
|
sub dep_satisfied {
|
|
my $p = shift;
|
|
my $check_backports = shift;
|
|
my $need_udeb = shift;
|
|
|
|
if ("ARRAY" eq ref $p) {
|
|
foreach (@{$p}) {
|
|
if (dep_pkg_included($_, $check_backports, $need_udeb)) {
|
|
return 1;
|
|
}
|
|
}
|
|
} elsif ("HASH" eq ref $p) {
|
|
return dep_pkg_included($p, $check_backports, $need_udeb);
|
|
} else {
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub read_ordepends {
|
|
my $i = shift;
|
|
my $lines = shift;
|
|
my @or = ();
|
|
my ($val, $dep, $last) = ('','',0);
|
|
my ($op, $version);
|
|
|
|
chomp $lines->[$$i];
|
|
|
|
while ($lines->[$$i]
|
|
=~ m/^\s([\s\|])((?:Pre)?Depends|Suggests|Recommends): (\S+)( \((\S+) (\S+)\))*/) {
|
|
$val = $3;
|
|
if (defined $4) {
|
|
$op = $5;
|
|
$version = $6;
|
|
} else {
|
|
$op = "";
|
|
$version = "";
|
|
}
|
|
$last = 1 if $1 ne '|'; #Stop when no more '|'
|
|
if ($val =~ m/^<.*>$/) {
|
|
$dep = read_virtualdepends ($i, $lines);
|
|
if (ref $dep) {
|
|
push @or, @{$dep};
|
|
} else {
|
|
push @or, $dep;
|
|
}
|
|
} else {
|
|
my %elt;
|
|
$elt{"Package"} = $val;
|
|
$elt{"CmpOp"} = $op;
|
|
$elt{"Version"} = $version;
|
|
push @or, \%elt;
|
|
$$i++;
|
|
# Hack for packages providing not a truly
|
|
# virtual package
|
|
while ($lines->[$$i] =~ m/^\s{4}(\S+)( \((\S+) (\S+)\))*/) {
|
|
my %elt1;
|
|
$elt1{"Package"} = $1;
|
|
if (defined $2) {
|
|
$elt1{"CmpOp"} = $3;
|
|
$elt1{"Version"} = $4;
|
|
} else {
|
|
$elt1{"CmpOp"} = "";
|
|
$elt1{"Version"} = "";
|
|
}
|
|
msg(1, " " . dump_depend(\%elt1) . "\n");
|
|
push @or, \%elt1;
|
|
$$i++;
|
|
}
|
|
}
|
|
last if $last;
|
|
}
|
|
return \@or;
|
|
}
|
|
|
|
sub read_virtualdepends {
|
|
my $i = shift;
|
|
my $lines = shift;
|
|
my $virtual;
|
|
my @or = ();
|
|
|
|
#Check for the lines with <>
|
|
if ($lines->[$$i]
|
|
=~ m/^\s[\s\|]((?:Pre)?Depends|Recommends|Suggests): <([^>]+)>/) {
|
|
$virtual = $2;
|
|
$$i++
|
|
}
|
|
# Now look at the alternatives on the following lines
|
|
while ($lines->[$$i] =~ m/^\s{4}(\S+)( \((\S+) (\S+)\))*/) {
|
|
my %elt;
|
|
$elt{"Package"} = $1;
|
|
if (defined $2) {
|
|
$elt{"CmpOp"} = $3;
|
|
$elt{"Version"} = $4;
|
|
} else {
|
|
$elt{"CmpOp"} = "";
|
|
$elt{"Version"} = "";
|
|
}
|
|
push @or, \%elt;
|
|
$$i++;
|
|
}
|
|
if (@or) {
|
|
return \@or;
|
|
} else {
|
|
my %elt;
|
|
$elt{"Package"} = $virtual;
|
|
$elt{"CmpOp"} = "";
|
|
$elt{"Version"} = "";
|
|
push @or, \%elt;
|
|
return \@or;
|
|
}
|
|
}
|
|
|
|
sub add_package {
|
|
my $p = shift;
|
|
my $check_backports = shift;
|
|
my ($ok, $reasons);
|
|
|
|
msg(2, "+ Trying to add $p...\n");
|
|
if ($included{$p}) {
|
|
msg(2, " Already included ...\n");
|
|
return;
|
|
}
|
|
|
|
# Get all dependencies (not yet included) of each package
|
|
my (@dep) = (get_missing ($p, $check_backports));
|
|
|
|
# Stop here if apt failed
|
|
if (not scalar(@dep)) {
|
|
msg(2, "Can't add $p ... dependency problem.\n");
|
|
return;
|
|
}
|
|
|
|
if ($packages{$p}{"Size"} > $max_pkg_size) {
|
|
$size = $packages{$p}{"Size"};
|
|
msg(2, "Can't add $p ... too big! ($size > $max_pkg_size)\n");
|
|
$excluded{$p} = 'toobig';
|
|
return;
|
|
}
|
|
|
|
msg(3, " \@dep before checklist = " . dump_depend(\@dep) . "\n");
|
|
|
|
# Check if all packages are allowed (fail if one cannot)
|
|
($ok, $reasons) = check_list (\@dep, 1, $check_backports);
|
|
if (not $ok) {
|
|
msg(2, "Can't add $p ... one of the packages needed has " .
|
|
"been refused. Reasons: $reasons\n");
|
|
return;
|
|
}
|
|
|
|
msg(3, " \@dep after checklist = " . dump_depend(\@dep) . "\n");
|
|
|
|
# All packages are ok, now list them out and add sizes
|
|
foreach my $t (@dep) {
|
|
my %t = %$t;
|
|
my $pkgname = $t{"Package"};
|
|
add_to_output($pkgname);
|
|
}
|
|
}
|
|
|
|
sub accepted {
|
|
my $p = shift;
|
|
if (exists $excluded{$p}) {
|
|
return not $excluded{$p}
|
|
}
|
|
# Return false for a non-existent package ...
|
|
return 0;
|
|
}
|
|
|
|
sub get_missing {
|
|
my $p = shift;
|
|
my $check_backports = shift;
|
|
my @deps_list = ();
|
|
my %t;
|
|
my $dep_text;
|
|
my $found_missing = 0;
|
|
|
|
$t{"Package"} = $p;
|
|
$t{"CmpOp"} = "";
|
|
$t{"Version"} = "";
|
|
|
|
if (add_missing (\@deps_list, $packages{$p}{"Depends"}, \%t, 0, $check_backports)) {
|
|
$found_missing = 1;
|
|
}
|
|
|
|
if ($add_rec and add_missing (\@deps_list, $packages{$p}{"Recommends"}, \%t, 1, $check_backports)) {
|
|
$found_missing = 1;
|
|
}
|
|
|
|
if ($add_sug and add_missing (\@deps_list, $packages{$p}{"Suggests"}, \%t, 1, $check_backports)) {
|
|
$found_missing = 1;
|
|
}
|
|
|
|
if (not $found_missing) {
|
|
return ();
|
|
}
|
|
|
|
# Explicitly move the package itself to the end of the list,
|
|
# i.e. *after* all its dependencies
|
|
remove_entry(\%t, \@deps_list);
|
|
push @deps_list, \%t;
|
|
|
|
return (@deps_list);
|
|
}
|
|
|
|
# Recursive function adding packages to our list
|
|
sub add_missing {
|
|
my $list = shift;
|
|
my $new = shift;
|
|
my $pkgin = shift;
|
|
my @backup = @{$list};
|
|
my $ok = 1;
|
|
my $soft_depend = shift;
|
|
my $check_backports = shift;
|
|
my (%pkgin);
|
|
|
|
if (ref $pkgin eq "HASH") {
|
|
%pkgin = %$pkgin;
|
|
} else {
|
|
die "add_missing passed a non-hash";
|
|
}
|
|
|
|
my $need_udeb = $packages{$pkgin{"Package"}}{"IsUdeb"};
|
|
my $pkgname = $pkgin{"Package"};
|
|
|
|
# Check all dependencies
|
|
foreach my $thisdep (@{$new}) {
|
|
my $textout = "";
|
|
my $type_rel = "simple";
|
|
|
|
if ("ARRAY" ne ref($thisdep)) {
|
|
die "add_missing: $thisdep should be an array!\n";
|
|
}
|
|
|
|
# Print out status
|
|
if (scalar(@{$thisdep} > 1)) {
|
|
$textout = "(OR ";
|
|
$type_rel = "OR";
|
|
}
|
|
foreach my $orpkg (@{$thisdep}) {
|
|
$textout .= dump_depend($orpkg) . " ";
|
|
}
|
|
if (scalar(@{$thisdep} > 1)) {
|
|
$textout .= ")";
|
|
}
|
|
msg(3, " $pkgname Dep: $textout soft_depend $soft_depend\n");
|
|
|
|
# Bail out early if we can!
|
|
if (dep_satisfied ($thisdep, $check_backports, $need_udeb)) {
|
|
next;
|
|
}
|
|
|
|
# Still work to do...
|
|
my $or_ok = 0;
|
|
|
|
# First check all the OR packages up-front with no
|
|
# recursion. If *any* one of them is already installed, it
|
|
# will do.
|
|
foreach my $pkg (@{$thisdep}) {
|
|
my %t = %$pkg;
|
|
my $pkgname = lc $t{"Package"};
|
|
|
|
if (exists $packages{$pkgname} &&
|
|
($packages{$pkgname}{"Size"} > $max_pkg_size)) {
|
|
msg(2, " $pkgname is too big, mark it as excluded\n");
|
|
$excluded{$pkgname} = 'toobig';
|
|
}
|
|
|
|
# Already installed?
|
|
if (dep_satisfied($pkg, $check_backports, $need_udeb)) {
|
|
msg(3, " $type_rel relationship already installed: " . dump_depend($pkg) . "\n");
|
|
$or_ok = 1;
|
|
last;
|
|
}
|
|
|
|
# Pulled in already somewhere above us in the
|
|
# depth-first search? (yes, we have to cope with
|
|
# circular dependencies here...)
|
|
if (is_in_dep_list($pkg, $list, $soft_depend)) {
|
|
msg(3, " $type_rel relationship already satisfied by current list " . dump_depend($pkg) . "\n");
|
|
$or_ok = 1;
|
|
last;
|
|
}
|
|
# else
|
|
msg(3, " " . dump_depend($pkg) . " not already installed\n");
|
|
}
|
|
|
|
# If we don't have any of the OR packages, then start
|
|
# again and try them in order. We always add the first
|
|
# package in the OR to allow APT to figure out which is
|
|
# the better one to install for any combination of
|
|
# packages that have similar alternative dependencies, but
|
|
# in different order. Having the first alternative
|
|
# available should be good enough for all cases we care
|
|
# about.
|
|
if (not $or_ok) {
|
|
msg(3, " $type_rel relationship not already satisfied, looking at alternatives in order, check_backports $check_backports\n");
|
|
|
|
foreach my $pkg (@{$thisdep}) {
|
|
my %t = %$pkg;
|
|
my $pkgname = $t{"Package"};
|
|
if (not accepted($pkgname)) {
|
|
if ($check_backports && accepted("$pkgname/$codename-backports")) {
|
|
$pkgname = "$pkgname/$codename-backports";
|
|
$t{"Package"} = $pkgname;
|
|
} else {
|
|
next;
|
|
}
|
|
}
|
|
|
|
# Stop after the first
|
|
# package that is
|
|
# added successfully
|
|
# FIXME! NEED TO CHECK IF VERSION DEPS ARE SATISFIED, FALL BACK TO BPO VERSION
|
|
push (@{$list}, $pkg);
|
|
if (add_missing ($list, $packages{$pkgname}{"Depends"}, $pkg, $soft_depend, $check_backports)) {
|
|
$or_ok = 1;
|
|
if ($add_rec) {
|
|
add_missing ($list, $packages{$pkgname}{"Recommends"}, $pkg, 1, $check_backports);
|
|
}
|
|
if ($add_sug) {
|
|
add_missing ($list, $packages{$pkgname}{"Suggests"}, $pkg, 1, $check_backports);
|
|
}
|
|
remove_entry($pkg, $list);
|
|
push @{$list}, $pkg;
|
|
last;
|
|
} else {
|
|
pop @{$list};
|
|
}
|
|
}
|
|
}
|
|
$ok &&= $or_ok;
|
|
if (not $ok) {
|
|
$pkgname = $pkgin{"Package"};
|
|
if ($soft_depend) {
|
|
msg(1, " $pkgname failed, couldn't satisfy $type_rel dep (but it's a soft dep, so ignoring...)\n");
|
|
$ok = 1;
|
|
} else {
|
|
msg(1, " $pkgname failed, couldn't satisfy $type_rel dep\n");
|
|
}
|
|
}
|
|
}
|
|
# If a problem has come up, then restore the original list
|
|
if (not $ok) {
|
|
@{$list} = @backup;
|
|
}
|
|
if (not is_in_dep_list(\%pkgin, $list, $soft_depend)) {
|
|
push @{$list}, \%pkgin;
|
|
}
|
|
return $ok;
|
|
}
|
|
|
|
# Check if $value is in @{$array}
|
|
sub is_in {
|
|
my $value = shift;
|
|
my $array = shift;
|
|
foreach my $key (@{$array}) {
|
|
return 1 if ($key eq $value);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
# Check if a package dependency is already in a dependency list
|
|
sub is_in_dep_list {
|
|
my $hash = shift;
|
|
my $array = shift;
|
|
my $soft_dep = shift // 0; # When analyzing recommends
|
|
my %t = %$hash;
|
|
|
|
foreach my $key (@{$array}) {
|
|
my %a = %$key;
|
|
if ($a{"Package"} eq $t{"Package"}) {
|
|
my $pn = $a{"Package"};
|
|
if ($soft_dep) {
|
|
# We don't have to ensure exact version when we analyze
|
|
# Recommends/Suggests
|
|
return 1;
|
|
} elsif (check_versions($t{"Version"}, $t{"CmpOp"}, $packages{$pn}{"Version"})) {
|
|
return 1;
|
|
}
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
# Remove an antry from @{$array}
|
|
sub remove_entry {
|
|
my $tmp1 = shift;
|
|
my $array = shift;
|
|
my $entries = scalar(@{$array});
|
|
my $i;
|
|
my %t1 = %$tmp1;
|
|
|
|
for ($i=0; $i < $entries; $i++) {
|
|
my $tmp2 = @{$array}[$i];
|
|
my %t2 = %$tmp2;
|
|
if ($t1{"Package"} eq $t2{"Package"}) {
|
|
splice(@{$array}, $i, 1);
|
|
$i--;
|
|
$entries--;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Check a list of packages
|
|
sub check_list {
|
|
my $ref = shift;
|
|
my $fail = shift;
|
|
my $check_backports = shift;
|
|
my $ok = 1;
|
|
my @to_remove = ();
|
|
my $reasons = "";
|
|
foreach my $thispkg (@{$ref}) {
|
|
my %t = %$thispkg;
|
|
my $pkgname = $t{"Package"};
|
|
if (not exists $excluded{$pkgname}) {
|
|
msg(1," $pkgname has been refused because it doesn't exist ...\n");
|
|
$ok = 0;
|
|
push @to_remove, $thispkg;
|
|
$reasons = $reasons . " noexist";
|
|
next;
|
|
}
|
|
if (not accepted($pkgname)) {
|
|
my $text = $excluded{"$pkgname"};
|
|
msg(1," $pkgname has been refused because of $text ...\n");
|
|
$ok = 0;
|
|
push @to_remove, $thispkg;
|
|
$reasons = $reasons . " " . $excluded{$pkgname};
|
|
next;
|
|
}
|
|
if ($check_backports &&
|
|
($pkgname !~ /\/$codename-backports/) &&
|
|
(not accepted("$pkgname/$codename-backports"))) {
|
|
my $text = $excluded{"$pkgname/$codename-backports"};
|
|
msg(1," $pkgname/$codename-backports has been refused because of $text} ...\n");
|
|
$ok = 0;
|
|
push @to_remove, $thispkg;
|
|
$reasons = $reasons . " " . $excluded{$pkgname};
|
|
next;
|
|
}
|
|
if ($included{$pkgname}) {
|
|
msg(1, " $pkgname has already been included.\n");
|
|
push @to_remove, $thispkg;
|
|
$reasons = $reasons . " alreadyinc";
|
|
next;
|
|
}
|
|
if ($check_backports && $included{"$pkgname/$codename-backports"}) {
|
|
msg(1, " $pkgname/$codename-backports has already been included.\n");
|
|
push @to_remove, $thispkg;
|
|
$reasons = $reasons . " alreadyinc";
|
|
next;
|
|
}
|
|
}
|
|
foreach my $removed (@to_remove) {
|
|
my %t = %$removed;
|
|
my $pkgname = $t{"Package"};
|
|
msg(2, " Removing $pkgname ... ($reasons )\n");
|
|
@{$ref} = grep { $_ ne $removed } @{$ref};
|
|
}
|
|
return ($fail ? $ok : 1, $reasons);
|
|
}
|
|
|
|
# Add packages to the output list
|
|
sub add_to_output {
|
|
my $pkgname = shift;
|
|
my $size = $packages{$pkgname}{"Size"};
|
|
|
|
$output_size += $size;
|
|
$included{$pkgname} = 1;
|
|
push(@output, $pkgname);
|
|
}
|
|
|
|
sub yesno {
|
|
my $in = shift;
|
|
return $in ? "yes" : "no";
|
|
}
|