Dpkg::Deps: Arch qualifiers only imply one another if they are the same

Because we are handling dependencies in isolation, and the full context
of the implications are only known when doing dependency resolution at
run-time, we can only assert that they are implied if they are equal.

Closes: #745366, #827628

debian/changelog

@@ -65,6 +65,8 @@ dpkg (1.18.8) UNRELEASED; urgency=medium
       type, new recognized fields to Dpkg::Control::Fields, and new modules
       Dpkg::Control::Tests and Dpkg::Control::Tests::Entry. Also update
       Dpkg::Index to support these.
+    - Fix Dpkg::Deps so that architecture qualifiers only imply one another
+      if they are the same. Closes: #745366, #827628
   * Test suite:
     - Bump perlcritic ValuesAndExpressions::RequireNumberSeparators minimum
       to 99999.

scripts/Dpkg/Deps.pm

@@ -742,26 +742,21 @@ sub _arch_is_superset {
     return 1;
 }
 
-# _arch_qualifier_allows_implication($p, $q)
+# _arch_qualifier_implies($p, $q)
 #
 # Returns true if the arch qualifier $p and $q are compatible with the
-# implication $p -> $q, false otherwise. $p/$q can be
-# undef/"any"/"native" or an architecture string.
-sub _arch_qualifier_allows_implication {
+# implication $p -> $q, false otherwise. $p/$q can be undef/"any"/"native"
+# or an architecture string.
+#
+# Because we are handling dependencies in isolation, and the full context
+# of the implications are only known when doing dependency resolution at
+# run-time, we can only assert that they are implied if they are equal.
+sub _arch_qualifier_implies {
     my ($p, $q) = @_;
-    if (defined $p and $p eq 'any') {
-	return 1 if defined $q and $q eq 'any';
-	return 0;
-    } elsif (defined $p and $p eq 'native') {
-	return 1 if defined $q and ($q eq 'any' or $q eq 'native');
-	return 0;
-    } elsif (defined $p) {
-	return 1 if defined $q and ($p eq $q or $q eq 'any');
-	return 0;
-    } else {
-	return 0 if defined $q and $q ne 'any' and $q ne 'native';
-	return 1;
-    }
+
+    return $p eq $q if defined $p and defined $q;
+    return 1 if not defined $p and not defined $q;
+    return 0;
 }
 
 # Returns true if the dependency in parameter can deduced from the current
@@ -778,8 +773,8 @@ sub implies {
 	return unless _arch_is_superset($self->{arches}, $o->{arches});
 
 	# The arch qualifier must not forbid an implication
-	return unless _arch_qualifier_allows_implication($self->{archqual},
-	                                                 $o->{archqual});
+	return unless _arch_qualifier_implies($self->{archqual},
+	                                      $o->{archqual});
 
 	# If o has no version clause, then our dependency is stronger
 	return 1 if not defined $o->{relation};

scripts/t/Dpkg_Deps.t

@@ -16,7 +16,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 52;
+use Test::More tests => 58;
 
 use Dpkg::Arch qw(get_host_arch);
 use Dpkg::Version;
@@ -55,13 +55,20 @@ my $dep_or2 = deps_parse('x|y|a|b|c (<= 0.5)|c (>=1.5)|d|e');
 is($dep_or1->implies($dep_or2), 1, 'Implication between OR 1/2');
 is($dep_or2->implies($dep_or1), undef, 'Implication between OR 2/2');
 
+my $dep_ma_host = deps_parse('libcairo2');
 my $dep_ma_any = deps_parse('libcairo2:any');
-my $dep_ma_native = deps_parse('libcairo2');
-my $dep_ma_native2 = deps_parse('libcairo2:native', build_dep => 1);
-is($dep_ma_native->implies($dep_ma_any), 1, 'foo -> foo:any');
-is($dep_ma_native2->implies($dep_ma_any), 1, 'foo:native -> foo:any');
-is($dep_ma_any->implies($dep_ma_native), undef, 'foo:any !-> foo');
-is($dep_ma_any->implies($dep_ma_native2), undef, 'foo:any !-> foo:native');
+my $dep_ma_build = deps_parse('libcairo2:native', build_dep => 1);
+my $dep_ma_explicit = deps_parse('libcairo2:amd64');
+is($dep_ma_host->implies($dep_ma_any), undef, 'foo !-> foo:any');
+is($dep_ma_build->implies($dep_ma_any), undef, 'foo:native !-> foo:any');
+is($dep_ma_explicit->implies($dep_ma_any), undef, 'foo:<arch> !-> foo:any');
+is($dep_ma_any->implies($dep_ma_host), undef, 'foo:any !-> foo');
+is($dep_ma_any->implies($dep_ma_build), undef, 'foo:any !-> foo:native');
+is($dep_ma_any->implies($dep_ma_explicit), undef, 'foo:any !-> foo:<arch>');
+is($dep_ma_host->implies($dep_ma_host), 1, 'foo -> foo');
+is($dep_ma_any->implies($dep_ma_any), 1, 'foo:any -> foo:any');
+is($dep_ma_build->implies($dep_ma_build), 1, 'foo:native -> foo:native');
+is($dep_ma_explicit->implies($dep_ma_explicit), 1, 'foo:<arch>-> foo:<arch>');
 
 my $field_tests = 'self, @, @builddeps@';
 $SIG{__WARN__} = sub {};