scripts/t/Dpkg_Arch.t

   1 #!/usr/bin/perl
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  15
  16 use strict;
  17 use warnings;
  18
  19 use Test::More tests => 17421;
  20
  21 use_ok('Dpkg::Arch', qw(debarch_to_debtuple debarch_to_multiarch
  22                         debarch_eq debarch_is debarch_is_wildcard
  23                         debarch_is_illegal
  24                         debarch_to_abiattrs debarch_to_cpubits
  25                         debarch_list_parse
  26                         debtuple_to_debarch gnutriplet_to_debarch
  27                         debtuple_to_gnutriplet gnutriplet_to_debtuple
  28                         get_host_gnu_type
  29                         get_valid_arches));
  30
  31 my $KNOWN_ARCHES_TOTAL = 524;
  32 my @valid_arches = get_valid_arches();
  33
  34 sub get_valid_wildcards
  35 {
  36     my %wildcards;
  37     my @wildcards_base = qw(
  38         any
  39         any-any
  40         any-any-any
  41         any-any-any-any
  42     );
  43
  44     foreach my $archname (@valid_arches) {
  45         my @tuple = debarch_to_debtuple($archname);
  46
  47         my @wildcards_arch = (
  48             # Two element tuples.
  49             "$tuple[2]-any",
  50             "any-$tuple[3]",
  51
  52             # Three element tuples.
  53             "$tuple[1]-$tuple[2]-any",
  54             "$tuple[1]-any-$tuple[3]",
  55             "$tuple[1]-any-any",
  56             "any-$tuple[2]-$tuple[3]",
  57             "any-$tuple[2]-any",
  58             "any-any-$tuple[3]",
  59
  60             # Four element tuples.
  61             "$tuple[0]-$tuple[1]-$tuple[2]-any",
  62             "$tuple[0]-$tuple[1]-any-$tuple[3]",
  63             "$tuple[0]-$tuple[1]-any-any",
  64             "$tuple[0]-any-$tuple[2]-$tuple[3]",
  65             "$tuple[0]-any-$tuple[2]-any",
  66             "$tuple[0]-any-any-$tuple[3]",
  67             "$tuple[0]-any-any-any",
  68             "any-$tuple[1]-$tuple[2]-$tuple[3]",
  69             "any-$tuple[1]-$tuple[2]-any",
  70             "any-$tuple[1]-any-$tuple[3]",
  71             "any-$tuple[1]-any-any",
  72             "any-any-$tuple[2]-$tuple[3]",
  73             "any-any-$tuple[2]-any",
  74             "any-any-any-$tuple[3]",
  75         );
  76
  77         foreach my $wildcard ((@wildcards_base, @wildcards_arch)) {
  78             push @{$wildcards{$wildcard}}, $archname;
  79         }
  80     }
  81
  82     return \%wildcards;
  83 }
  84
  85 my @tuple_new;
  86 my @tuple_ref;
  87
  88 @tuple_new = debarch_to_debtuple('unknown');
  89 is_deeply(\@tuple_new, [], 'unknown tuple');
  90
  91 @tuple_ref = qw(base gnu linux amd64);
  92 @tuple_new = debarch_to_debtuple('amd64');
  93 is_deeply(\@tuple_new, \@tuple_ref, 'valid tuple');
  94
  95 @tuple_ref = qw(base gnu linux amd64);
  96 @tuple_new = debarch_to_debtuple('amd64');
  97 is_deeply(\@tuple_new, \@tuple_ref, 'valid tuple');
  98 @tuple_new = debarch_to_debtuple('linux-amd64');
  99 is_deeply(\@tuple_new, \@tuple_ref, 'valid tuple');
 100
 101 is(debarch_to_multiarch('i386'), 'i386-linux-gnu',
 102    'normalized i386 multiarch triplet');
 103 is(debarch_to_multiarch('amd64'), 'x86_64-linux-gnu',
 104    'normalized amd64 multiarch triplet');
 105
 106 ok(!debarch_eq('amd64', 'i386'), 'no match, simple arch');
 107 ok(!debarch_eq('', 'amd64'), 'no match, empty first arch');
 108 ok(!debarch_eq('amd64', ''), 'no match, empty second arch');
 109 ok(!debarch_eq('amd64', 'unknown'), 'no match, with first unknown arch');
 110 ok(!debarch_eq('unknown', 'i386'), 'no match, second unknown arch');
 111 ok(debarch_eq('unknown', 'unknown'), 'match equal unknown arch');
 112 ok(debarch_eq('amd64', 'amd64'), 'match equal known arch');
 113 ok(debarch_eq('amd64', 'linux-amd64'), 'match implicit linux arch');
 114
 115 ok(!debarch_is('unknown', 'linux-any'), 'no match unknown on wildcard cpu');
 116 ok(!debarch_is('unknown', 'any-amd64'), 'no match unknown on wildcard os');
 117 ok(!debarch_is('amd64', 'unknown'), 'no match amd64 on unknown wildcard');
 118 ok(!debarch_is('amd64', 'unknown-any'), 'no match amd64 on unknown wildcard');
 119 ok(!debarch_is('amd64', 'any-unknown'), 'no match amd64 on unknown wildcard');
 120 ok(debarch_is('unknown', 'any'), 'match unknown on global wildcard');
 121 ok(debarch_is('linux-amd64', 'linux-any'), 'match implicit linux-amd64 on wildcard cpu');
 122 ok(debarch_is('linux-amd64', 'any-amd64'), 'match implicit linux-amd64 on wildcard os');
 123
 124 my $wildcards = get_valid_wildcards();
 125
 126 foreach my $wildcard (sort keys %{$wildcards}) {
 127     ok(debarch_is_wildcard($wildcard), "$wildcard is a wildcard");
 128
 129     foreach my $arch (sort @{$wildcards->{$wildcard}}) {
 130         ok(debarch_is($arch, $wildcard), "wildcard $wildcard matches $arch");
 131     }
 132 }
 133
 134 ok(!debarch_is_wildcard('unknown'), 'unknown is not a wildcard');
 135 ok(!debarch_is_wildcard('all'), 'all is not a wildcard');
 136 ok(!debarch_is_wildcard('amd64'), '<arch> is not a wildcard');
 137
 138 ok(!debarch_is_illegal('0'), '');
 139 ok(!debarch_is_illegal('a'), '');
 140 ok(!debarch_is_illegal('amd64'), '');
 141 ok(!debarch_is_illegal('!arm64'), '');
 142 ok(!debarch_is_illegal('kfreebsd-any'), '');
 143 ok(debarch_is_illegal('!amd64!arm'), '');
 144 ok(debarch_is_illegal('arch%name'), '');
 145 ok(debarch_is_illegal('-any'), '');
 146 ok(debarch_is_illegal('!'), '');
 147
 148 my @arch_new;
 149 my @arch_ref;
 150
 151 @arch_ref = qw(amd64 !arm64 linux-i386 !kfreebsd-any);
 152 @arch_new = debarch_list_parse('amd64  !arm64   linux-i386 !kfreebsd-any');
 153 is_deeply(\@arch_new, \@arch_ref, 'parse valid arch list');
 154
 155 @arch_ref = qw(amd64 arm64 linux-i386 kfreebsd-any);
 156 @arch_new = debarch_list_parse('amd64  arm64   linux-i386 kfreebsd-any', positive => 1);
 157 is_deeply(\@arch_new, \@arch_ref, 'parse valid positive arch list');
 158
 159 eval { @arch_new = debarch_list_parse('!amd64!arm64') };
 160 ok($@, 'parse concatenated arches failed');
 161
 162 eval { @arch_new = debarch_list_parse('amd64 !arm64 !mips', positive => 1) };
 163 ok($@, 'parse disallowed negated arches failed');
 164
 165 is(debarch_to_abiattrs(undef), undef, 'undef ABI attrs');
 166 is_deeply([ debarch_to_abiattrs('amd64') ], [ qw(64 little) ], 'amd64 ABI attrs');
 167 is_deeply([ debarch_to_abiattrs('x32') ], [ qw(32 little) ], 'x32 ABI attrs');
 168
 169 is(debarch_to_cpubits(undef), undef, 'undef CPU bits');
 170 is(debarch_to_cpubits('i386'), 32, 'i386 CPU bits');
 171 is(debarch_to_cpubits('amd64'), 64, 'amd64 CPU bits');
 172
 173 is(debtuple_to_debarch((undef) x 4), undef, 'undef debtuple');
 174 is(debtuple_to_debarch('base', 'gnu', 'linux', 'amd64'), 'amd64', 'known debtuple');
 175 is(debtuple_to_debarch('unknown', 'unknown', 'unknown', 'unknown'), undef, 'unknown debtuple');
 176
 177 is(gnutriplet_to_debarch(undef), undef, 'undef gnutriplet');
 178 is(gnutriplet_to_debarch('unknown-unknown-unknown'), undef, 'unknown gnutriplet');
 179 is(gnutriplet_to_debarch('x86_64-linux-gnu'), 'amd64', 'known gnutriplet');
 180
 181 foreach my $arch (@valid_arches) {
 182     my @tuple = debarch_to_debtuple($arch);
 183     is(debtuple_to_debarch(@tuple), $arch,
 184        "bijective arch $arch to tuple @tuple");
 185
 186     my $triplet = debtuple_to_gnutriplet(@tuple);
 187     is_deeply([ gnutriplet_to_debtuple($triplet) ], \@tuple,
 188               "bijective triplet $triplet to tuple @tuple");
 189 }
 190
 191 is(scalar @valid_arches, $KNOWN_ARCHES_TOTAL,
 192     'expected amount of known architectures');
 193
 194 {
 195     local $ENV{CC} = 'false';
 196     is(get_host_gnu_type(), '', 'CC does not support -dumpmachine');
 197
 198     $ENV{CC} = 'echo CC';
 199     is(get_host_gnu_type(), 'CC -dumpmachine',
 200        'CC does not report expected synthetic result for -dumpmachine');
 201 }