findarchwildcardproblems/findarchwildcardproblems.pl

#!/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::Deps qw(deps_parse deps_iterate);
use Dpkg::Index;
use List::MoreUtils qw{any};
use List::Util qw{first};
use Dpkg::Arch qw(debarch_is);
use Dpkg::Control::FieldsCore qw(field_list_src_dep);

my $desc = $ARGV[0]; # /home/josch/gsoc2012/bootstrap/tests/sid-sources-20140101T000000Z
if (not defined($desc)) {
    die "need filename";
}

my $key_func = sub {
   return $_[0]->{Package} . '_' . $_[0]->{Version};
};

my $index = Dpkg::Index->new(get_key_func=>$key_func);

$index->load($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");

foreach my $key ($index->get_keys()) {
    my $cdata = $index->get_by_key($key);
    my $pkgname = $cdata->{"Package"};
    next if not defined($pkgname);
    my @depfields = field_list_src_dep();
    foreach my $depfield (@depfields) {
        my $dep_line = $cdata->{$depfield};
        next if not defined($dep_line);
      my $dep_iter = deps_parse($dep_line);
      deps_iterate($dep_iter, sub {
            my $dep_simple = shift;
                my $depname = $dep_simple->{package};
                return 1 if not defined($depname);
                my $arches = $dep_simple->{arches};
                return 1 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";
                    }
                }
            return 1;
        });
    }
    # 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";
                }
            }
        }
    }
}