josch/findarchwildcardproblems
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

initial commit

Browse source
This commit is contained in:
josch 2014-06-26 13:37:40 +02:00
commit f89dba4b4d
1 changed files with 143 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

143
findarchwildcardproblems.pl Executable file
View file

@ -0,0 +1,143 @@
#!/usr/bin/perl
use strict;
use warnings;
# print invalid architecture wildcards (doesnt match any existing architecture)
# and duplicate wildcards (an architecture is matched by more than one
# wildcard) in build dependencies, conflicts, the architecture field and in
# binary packages listed in the Package-List field
use Dpkg::Control;
use Dpkg::Compression::FileHandle;
use Dpkg::Deps;
use List::MoreUtils qw{any};
use List::Util qw{first};
use Dpkg::Arch qw(debarch_is);
my $desc = $ARGV[0]; # /home/josch/gsoc2012/bootstrap/tests/sid-sources-20140101T000000Z
if (not defined($desc)) {
die "need filename";
}
my $fh = Dpkg::Compression::FileHandle->new(filename => $desc);
my @debarches = ("amd64", "armel", "armhf", "hurd-i386", "i386", "kfreebsd-amd64", "kfreebsd-i386", "mips", "mipsel", "powerpc", "s390x", "sparc",
"alpha", "arm64", "hppa", "m68k", "powerpcspe", "ppc64", "sh4", "sparc64", "x32");
while (1) {
my $cdata = Dpkg::Control->new(type => CTRL_INDEX_SRC);
last if not $cdata->parse($fh, $desc);
my $pkgname = $cdata->{"Package"};
next if not defined($pkgname);
my @depfields = ('Build-Depends', 'Build-Depends-Indep', 'Build-Depends-Arch',
'Build-Conflicts', 'Build-Conflicts-Indep', 'Build-Conflicts-Arch');
# search for invalid arches in the dependency and conflict fields
foreach my $depfield (@depfields) {
my $dep_line = $cdata->{$depfield};
next if not defined($dep_line);
foreach my $dep_and (split(/\s*,\s*/m, $dep_line)) {
my @or_list = ();
foreach my $dep_or (split(/\s*\|\s*/m, $dep_and)) {
my $dep_simple = Dpkg::Deps::Simple->new($dep_or);
my $depname = $dep_simple->{package};
next if not defined($depname);
my $arches = $dep_simple->{arches};
next if not defined($arches);
# find wildcards that do not match any existing architecture
foreach my $arch (@{$arches}) {
$arch =~ s/^!//;
next if (any {debarch_is($_,$arch)} @debarches);
print "ID: $pkgname $arch $depname\n";
}
# search for duplicate arches in arch restrictions
# set match frequency to zero for all arches
my %matchfreq = ();
foreach my $arch (@debarches) {
$matchfreq{$arch} = 0;
}
# find duplicates
foreach my $arch (@{$arches}) {
$arch =~ s/^!//;
foreach my $a (@debarches) {
if (debarch_is($a, $arch)) {
$matchfreq{$a} += 1;
}
}
}
# print duplicate matches
foreach my $arch (@debarches) {
if ($matchfreq{$arch} > 1) {
print "DD: $pkgname $arch $depname\n";
}
}
}
}
}
# search for invalid arches in Architecture field
my $architecture = $cdata->{"Architecture"};
if (defined($architecture)) {
# find wildcards that do not match any existing architecture
foreach my $arch (split(/\s+/m, $architecture)) {
next if ($arch eq "all");
next if (any {debarch_is($_,$arch)} @debarches);
print "IA: $pkgname $arch\n";
}
# search for duplicate arches in Architecture field
# set match frequency to zero for all arches
my %matchfreq = ();
foreach my $arch (@debarches) {
$matchfreq{$arch} = 0;
}
# find duplicates
foreach my $arch (split(/\s+/m, $architecture)) {
next if ($arch eq "all");
foreach my $a (@debarches) {
if (debarch_is($a, $arch)) {
$matchfreq{$a} += 1;
}
}
}
# print duplicate matches
foreach my $arch (@debarches) {
if ($matchfreq{$arch} > 1) {
print "DA: $pkgname $arch\n";
}
}
}
# gather the architectures of the generated binary packages
my $packagelist = $cdata->{"Package-List"};
if (defined($packagelist)) {
foreach my $line (split(/\n/m, $packagelist)) {
my $architecture = first { /^arch=/ } split(/\s+/m, $line);
next if (not defined($architecture));
$architecture =~ s/^arch=//;
# find wildcards that do not match any existing architecture
foreach my $arch (split(/,/m, $architecture)) {
next if ($arch eq "all");
next if (any {debarch_is($_,$arch)} @debarches);
print "IB: $pkgname $arch\n";
}
# search for duplicate arches in Architecture field
# set match frequency to zero for all arches
my %matchfreq = ();
foreach my $arch (@debarches) {
$matchfreq{$arch} = 0;
}
# find duplicates
foreach my $arch (split(/,/m, $architecture)) {
next if ($arch eq "all");
foreach my $a (@debarches) {
if (debarch_is($a, $arch)) {
$matchfreq{$a} += 1;
}
}
}
# print duplicate matches
foreach my $arch (@debarches) {
if ($matchfreq{$arch} > 1) {
print "DB: $pkgname $arch\n";
}
}
}
}
}