File: | Dpkg/Arch.pm |
Coverage: | 89.1% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | # Copyright © 2006-2015 Guillem Jover <guillem@debian.org> | ||||||
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 | package Dpkg::Arch; | ||||||
17 | |||||||
18 | =encoding utf8 | ||||||
19 | |||||||
20 - 33 | =head1 NAME Dpkg::Arch - handle architectures =head1 DESCRIPTION The Dpkg::Arch module provides functions to handle Debian architectures, wildcards, and mapping from and to GNU triplets. No symbols are exported by default. The :all tag can be used to import all symbols. The :getters, :parsers, :mappers and :operators tags can be used to import specific symbol subsets. =cut | ||||||
34 | |||||||
35 | 65 65 65 | 133 52 660 | use strict; | ||||
36 | 65 65 65 | 71 12 1126 | use warnings; | ||||
37 | 65 65 65 | 80 51 5542 | use feature qw(state); | ||||
38 | |||||||
39 | our $VERSION = '1.03'; | ||||||
40 | our @EXPORT_OK = qw( | ||||||
41 | get_raw_build_arch | ||||||
42 | get_raw_host_arch | ||||||
43 | get_build_arch | ||||||
44 | get_host_arch | ||||||
45 | get_host_gnu_type | ||||||
46 | get_valid_arches | ||||||
47 | debarch_eq | ||||||
48 | debarch_is | ||||||
49 | debarch_is_wildcard | ||||||
50 | debarch_is_illegal | ||||||
51 | debarch_is_concerned | ||||||
52 | debarch_to_abiattrs | ||||||
53 | debarch_to_cpubits | ||||||
54 | debarch_to_gnutriplet | ||||||
55 | debarch_to_debtuple | ||||||
56 | debarch_to_multiarch | ||||||
57 | debarch_list_parse | ||||||
58 | debtuple_to_debarch | ||||||
59 | debtuple_to_gnutriplet | ||||||
60 | gnutriplet_to_debarch | ||||||
61 | gnutriplet_to_debtuple | ||||||
62 | gnutriplet_to_multiarch | ||||||
63 | ); | ||||||
64 | our %EXPORT_TAGS = ( | ||||||
65 | all => [ @EXPORT_OK ], | ||||||
66 | getters => [ qw( | ||||||
67 | get_raw_build_arch | ||||||
68 | get_raw_host_arch | ||||||
69 | get_build_arch | ||||||
70 | get_host_arch | ||||||
71 | get_host_gnu_type | ||||||
72 | get_valid_arches | ||||||
73 | ) ], | ||||||
74 | parsers => [ qw( | ||||||
75 | debarch_list_parse | ||||||
76 | ) ], | ||||||
77 | mappers => [ qw( | ||||||
78 | debarch_to_abiattrs | ||||||
79 | debarch_to_gnutriplet | ||||||
80 | debarch_to_debtuple | ||||||
81 | debarch_to_multiarch | ||||||
82 | debtuple_to_debarch | ||||||
83 | debtuple_to_gnutriplet | ||||||
84 | gnutriplet_to_debarch | ||||||
85 | gnutriplet_to_debtuple | ||||||
86 | gnutriplet_to_multiarch | ||||||
87 | ) ], | ||||||
88 | operators => [ qw( | ||||||
89 | debarch_eq | ||||||
90 | debarch_is | ||||||
91 | debarch_is_wildcard | ||||||
92 | debarch_is_illegal | ||||||
93 | debarch_is_concerned | ||||||
94 | ) ], | ||||||
95 | ); | ||||||
96 | |||||||
97 | |||||||
98 | 65 65 65 | 119 140 727 | use Exporter qw(import); | ||||
99 | 65 65 65 | 83 76 1432 | use List::Util qw(any); | ||||
100 | |||||||
101 | 65 65 65 | 485 13 436 | use Dpkg (); | ||||
102 | 65 65 65 | 528 51 1166 | use Dpkg::Gettext; | ||||
103 | 65 65 65 | 626 46 1572 | use Dpkg::ErrorHandling; | ||||
104 | 65 65 65 | 7595 59 2329 | use Dpkg::Build::Env; | ||||
105 | |||||||
106 | my (@cpu, @os); | ||||||
107 | my (%cputable, %ostable); | ||||||
108 | my (%cputable_re, %ostable_re); | ||||||
109 | my (%cpubits, %cpuendian); | ||||||
110 | my %abibits; | ||||||
111 | |||||||
112 | my %debtuple_to_debarch; | ||||||
113 | my %debarch_to_debtuple; | ||||||
114 | |||||||
115 - 124 | =head1 FUNCTIONS =over 4 =item $arch = get_raw_build_arch() Get the raw build Debian architecture, without taking into account variables from the environment. =cut | ||||||
125 | |||||||
126 | sub get_raw_build_arch() | ||||||
127 | { | ||||||
128 | 1 | 1 | 1 | state $build_arch; | |||
129 | |||||||
130 | 1 | 1 | return $build_arch if defined $build_arch; | ||||
131 | |||||||
132 | # Note: We *always* require an installed dpkg when inferring the | ||||||
133 | # build architecture. The bootstrapping case is handled by | ||||||
134 | # dpkg-architecture itself, by avoiding computing the DEB_BUILD_ | ||||||
135 | # variables when they are not requested. | ||||||
136 | |||||||
137 | ## no critic (TestingAndDebugging::ProhibitNoWarnings) | ||||||
138 | 65 65 65 | 122 52 4880 | no warnings qw(exec); | ||||
139 | 1 | 1623 | $build_arch = qx(dpkg --print-architecture); | ||||
140 | 1 | 16 | syserr('dpkg --print-architecture failed') if $? >> 8; | ||||
141 | |||||||
142 | 1 | 5 | chomp $build_arch; | ||||
143 | 1 | 16 | return $build_arch; | ||||
144 | } | ||||||
145 | |||||||
146 - 151 | =item $arch = get_build_arch() Get the build Debian architecture, using DEB_BUILD_ARCH from the environment if available. =cut | ||||||
152 | |||||||
153 | sub get_build_arch() | ||||||
154 | { | ||||||
155 | 17 | 1 | 14 | return Dpkg::Build::Env::get('DEB_BUILD_ARCH') || get_raw_build_arch(); | |||
156 | } | ||||||
157 | |||||||
158 | { | ||||||
159 | my %cc_host_gnu_type; | ||||||
160 | |||||||
161 | sub get_host_gnu_type() | ||||||
162 | { | ||||||
163 | 4 | 0 | 10 | my $CC = $ENV{CC} || 'gcc'; | |||
164 | |||||||
165 | 4 | 10 | return $cc_host_gnu_type{$CC} if defined $cc_host_gnu_type{$CC}; | ||||
166 | |||||||
167 | ## no critic (TestingAndDebugging::ProhibitNoWarnings) | ||||||
168 | 65 65 65 | 130 24 85536 | no warnings qw(exec); | ||||
169 | 3 | 64305 | $cc_host_gnu_type{$CC} = qx($CC -dumpmachine); | ||||
170 | 3 | 99 | if ($? >> 8) { | ||||
171 | 1 | 8 | $cc_host_gnu_type{$CC} = ''; | ||||
172 | } else { | ||||||
173 | 2 | 16 | chomp $cc_host_gnu_type{$CC}; | ||||
174 | } | ||||||
175 | |||||||
176 | 3 | 111 | return $cc_host_gnu_type{$CC}; | ||||
177 | } | ||||||
178 | |||||||
179 | sub set_host_gnu_type | ||||||
180 | { | ||||||
181 | 1 | 0 | 1 | my ($host_gnu_type) = @_; | |||
182 | 1 | 28 | my $CC = $ENV{CC} || 'gcc'; | ||||
183 | |||||||
184 | 1 | 4 | $cc_host_gnu_type{$CC} = $host_gnu_type; | ||||
185 | } | ||||||
186 | } | ||||||
187 | |||||||
188 - 193 | =item $arch = get_raw_host_arch() Get the raw host Debian architecture, without taking into account variables from the environment. =cut | ||||||
194 | |||||||
195 | sub get_raw_host_arch() | ||||||
196 | { | ||||||
197 | 1 | 1 | 1 | state $host_arch; | |||
198 | |||||||
199 | 1 | 1 | return $host_arch if defined $host_arch; | ||||
200 | |||||||
201 | 1 | 1 | my $host_gnu_type = get_host_gnu_type(); | ||||
202 | |||||||
203 | 1 | 1 | if ($host_gnu_type eq '') { | ||||
204 | 0 | 0 | warning(g_('cannot determine CC system type, falling back to ' . | ||||
205 | 'default (native compilation)')); | ||||||
206 | } else { | ||||||
207 | 1 | 7 | my (@host_archtuple) = gnutriplet_to_debtuple($host_gnu_type); | ||||
208 | 1 | 1 | $host_arch = debtuple_to_debarch(@host_archtuple); | ||||
209 | |||||||
210 | 1 | 1 | if (defined $host_arch) { | ||||
211 | 1 | 1 | $host_gnu_type = debtuple_to_gnutriplet(@host_archtuple); | ||||
212 | } else { | ||||||
213 | 0 | 0 | warning(g_('unknown CC system type %s, falling back to ' . | ||||
214 | 'default (native compilation)'), $host_gnu_type); | ||||||
215 | 0 | 0 | $host_gnu_type = ''; | ||||
216 | } | ||||||
217 | 1 | 1 | set_host_gnu_type($host_gnu_type); | ||||
218 | } | ||||||
219 | |||||||
220 | 1 | 1 | if (!defined($host_arch)) { | ||||
221 | # Switch to native compilation. | ||||||
222 | 0 | 0 | $host_arch = get_raw_build_arch(); | ||||
223 | } | ||||||
224 | |||||||
225 | 1 | 7 | return $host_arch; | ||||
226 | } | ||||||
227 | |||||||
228 - 233 | =item $arch = get_host_arch() Get the host Debian architecture, using DEB_HOST_ARCH from the environment if available. =cut | ||||||
234 | |||||||
235 | sub get_host_arch() | ||||||
236 | { | ||||||
237 | 56 | 1 | 69 | return Dpkg::Build::Env::get('DEB_HOST_ARCH') || get_raw_host_arch(); | |||
238 | } | ||||||
239 | |||||||
240 - 244 | =item @arch_list = get_valid_arches() Get an array with all currently known Debian architectures. =cut | ||||||
245 | |||||||
246 | sub get_valid_arches() | ||||||
247 | { | ||||||
248 | 1 | 1 | 1 | _load_cputable(); | |||
249 | 1 | 3 | _load_ostable(); | ||||
250 | |||||||
251 | 1 | 2 | my @arches; | ||||
252 | |||||||
253 | 1 | 1 | foreach my $os (@os) { | ||||
254 | 27 | 16 | foreach my $cpu (@cpu) { | ||||
255 | 999 | 643 | my $arch = debtuple_to_debarch(split(/-/, $os, 3), $cpu); | ||||
256 | 999 | 792 | push @arches, $arch if defined($arch); | ||||
257 | } | ||||||
258 | } | ||||||
259 | |||||||
260 | 1 | 53 | return @arches; | ||||
261 | } | ||||||
262 | |||||||
263 | my %table_loaded; | ||||||
264 | sub _load_table | ||||||
265 | { | ||||||
266 | 161456 | 89205 | my ($table, $loader) = @_; | ||||
267 | |||||||
268 | 161456 | 117917 | return if $table_loaded{$table}; | ||||
269 | |||||||
270 | 22 | 17 | local $_; | ||||
271 | 22 | 34 | local $/ = "\n"; | ||||
272 | |||||||
273 | 22 | 306 | open my $table_fh, '<', "$Dpkg::DATADIR/$table" | ||||
274 | or syserr(g_('cannot open %s'), $table); | ||||||
275 | 22 | 164 | while (<$table_fh>) { | ||||
276 | 1042 | 546 | $loader->($_); | ||||
277 | } | ||||||
278 | 22 | 69 | close $table_fh; | ||||
279 | |||||||
280 | 22 | 64 | $table_loaded{$table} = 1; | ||||
281 | } | ||||||
282 | |||||||
283 | sub _load_cputable | ||||||
284 | { | ||||||
285 | _load_table('cputable', sub { | ||||||
286 | 456 | 492 | if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) { | ||||
287 | 296 | 311 | $cputable{$1} = $2; | ||||
288 | 296 | 233 | $cputable_re{$1} = $3; | ||||
289 | 296 | 201 | $cpubits{$1} = $4; | ||||
290 | 296 | 216 | $cpuendian{$1} = $5; | ||||
291 | 296 | 358 | push @cpu, $1; | ||||
292 | } | ||||||
293 | 60065 | 79063 | }); | ||||
294 | } | ||||||
295 | |||||||
296 | sub _load_ostable | ||||||
297 | { | ||||||
298 | _load_table('ostable', sub { | ||||||
299 | 90 | 92 | if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) { | ||||
300 | 54 | 58 | $ostable{$1} = $2; | ||||
301 | 54 | 41 | $ostable_re{$1} = $3; | ||||
302 | 54 | 59 | push @os, $1; | ||||
303 | } | ||||||
304 | 1151 | 1064 | }); | ||||
305 | } | ||||||
306 | |||||||
307 | sub _load_abitable() | ||||||
308 | { | ||||||
309 | _load_table('abitable', sub { | ||||||
310 | 56 | 63 | if (m/^(?!\#)(\S+)\s+(\S+)/) { | ||||
311 | 12 | 21 | $abibits{$1} = $2; | ||||
312 | } | ||||||
313 | 41326 | 33469 | }); | ||||
314 | } | ||||||
315 | |||||||
316 | sub _load_tupletable() | ||||||
317 | { | ||||||
318 | 58914 | 40845 | _load_cputable(); | ||||
319 | |||||||
320 | _load_table('tupletable', sub { | ||||||
321 | 440 | 437 | if (m/^(?!\#)(\S+)\s+(\S+)/) { | ||||
322 | 264 | 168 | my $debtuple = $1; | ||||
323 | 264 | 150 | my $debarch = $2; | ||||
324 | |||||||
325 | 264 | 188 | if ($debtuple =~ /<cpu>/) { | ||||
326 | 120 | 59 | foreach my $_cpu (@cpu) { | ||||
327 | 4440 | 3102 | (my $dt = $debtuple) =~ s/<cpu>/$_cpu/; | ||||
328 | 4440 | 3082 | (my $da = $debarch) =~ s/<cpu>/$_cpu/; | ||||
329 | |||||||
330 | next if exists $debarch_to_debtuple{$da} | ||||||
331 | 4440 | 5693 | or exists $debtuple_to_debarch{$dt}; | ||||
332 | |||||||
333 | 4408 | 3103 | $debarch_to_debtuple{$da} = $dt; | ||||
334 | 4408 | 4506 | $debtuple_to_debarch{$dt} = $da; | ||||
335 | } | ||||||
336 | } else { | ||||||
337 | 144 | 149 | $debarch_to_debtuple{$2} = $1; | ||||
338 | 144 | 219 | $debtuple_to_debarch{$1} = $2; | ||||
339 | } | ||||||
340 | } | ||||||
341 | 58914 | 98053 | }); | ||||
342 | } | ||||||
343 | |||||||
344 | sub debtuple_to_gnutriplet(@) | ||||||
345 | { | ||||||
346 | 578 | 0 | 533 | my ($abi, $libc, $os, $cpu) = @_; | |||
347 | |||||||
348 | 578 | 463 | _load_cputable(); | ||||
349 | 578 | 1031 | _load_ostable(); | ||||
350 | |||||||
351 | return unless | ||||||
352 | defined $abi && defined $libc && defined $os && defined $cpu && | ||||||
353 | 578 | 3550 | exists $cputable{$cpu} && exists $ostable{"$abi-$libc-$os"}; | ||||
354 | 578 | 898 | return join('-', $cputable{$cpu}, $ostable{"$abi-$libc-$os"}); | ||||
355 | } | ||||||
356 | |||||||
357 | sub gnutriplet_to_debtuple($) | ||||||
358 | { | ||||||
359 | 573 | 0 | 329 | my $gnu = shift; | |||
360 | 573 | 399 | return unless defined($gnu); | ||||
361 | 572 | 659 | my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2); | ||||
362 | 572 | 892 | return unless defined($gnu_cpu) && defined($gnu_os); | ||||
363 | |||||||
364 | 572 | 396 | _load_cputable(); | ||||
365 | 572 | 720 | _load_ostable(); | ||||
366 | |||||||
367 | 572 | 542 | my ($os, $cpu); | ||||
368 | |||||||
369 | 572 | 447 | foreach my $_cpu (@cpu) { | ||||
370 | 10739 | 39885 | if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) { | ||||
371 | 571 | 366 | $cpu = $_cpu; | ||||
372 | 571 | 403 | last; | ||||
373 | } | ||||||
374 | } | ||||||
375 | |||||||
376 | 572 | 388 | foreach my $_os (@os) { | ||||
377 | 9534 | 45384 | if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) { | ||||
378 | 571 | 359 | $os = $_os; | ||||
379 | 571 | 368 | last; | ||||
380 | } | ||||||
381 | } | ||||||
382 | |||||||
383 | 572 | 1059 | return if !defined($cpu) || !defined($os); | ||||
384 | 571 | 1643 | return (split(/-/, $os, 3), $cpu); | ||||
385 | } | ||||||
386 | |||||||
387 - 391 | =item $multiarch = gnutriplet_to_multiarch($gnutriplet) Map a GNU triplet into a Debian multiarch triplet. =cut | ||||||
392 | |||||||
393 | sub gnutriplet_to_multiarch($) | ||||||
394 | { | ||||||
395 | 5 | 1 | 4 | my $gnu = shift; | |||
396 | 5 | 6 | my ($cpu, $cdr) = split(/-/, $gnu, 2); | ||||
397 | |||||||
398 | 5 | 9 | if ($cpu =~ /^i[4567]86$/) { | ||||
399 | 1 | 3 | return "i386-$cdr"; | ||||
400 | } else { | ||||||
401 | 4 | 8 | return $gnu; | ||||
402 | } | ||||||
403 | } | ||||||
404 | |||||||
405 - 409 | =item $multiarch = debarch_to_multiarch($arch) Map a Debian architecture into a Debian multiarch triplet. =cut | ||||||
410 | |||||||
411 | sub debarch_to_multiarch($) | ||||||
412 | { | ||||||
413 | 5 | 1 | 4 | my $arch = shift; | |||
414 | |||||||
415 | 5 | 5 | return gnutriplet_to_multiarch(debarch_to_gnutriplet($arch)); | ||||
416 | } | ||||||
417 | |||||||
418 | sub debtuple_to_debarch(@) | ||||||
419 | { | ||||||
420 | 1575 | 0 | 1104 | my ($abi, $libc, $os, $cpu) = @_; | |||
421 | |||||||
422 | 1575 | 1025 | _load_tupletable(); | ||||
423 | |||||||
424 | 1575 | 5822 | if (!defined $abi || !defined $libc || !defined $os || !defined $cpu) { | ||||
425 | 3 | 3 | return; | ||||
426 | } elsif (exists $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}) { | ||||||
427 | 1141 | 1586 | return $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}; | ||||
428 | } else { | ||||||
429 | 431 | 220 | return; | ||||
430 | } | ||||||
431 | } | ||||||
432 | |||||||
433 | sub debarch_to_debtuple($) | ||||||
434 | { | ||||||
435 | 57341 | 0 | 28205 | my $arch = shift; | |||
436 | |||||||
437 | 57341 | 35912 | return if not defined $arch; | ||||
438 | |||||||
439 | 57339 | 40482 | _load_tupletable(); | ||||
440 | |||||||
441 | 57339 | 84721 | if ($arch =~ /^linux-([^-]*)/) { | ||||
442 | # XXX: Might disappear in the future, not sure yet. | ||||||
443 | 6 | 6 | $arch = $1; | ||||
444 | } | ||||||
445 | |||||||
446 | 57339 | 35306 | my $tuple = $debarch_to_debtuple{$arch}; | ||||
447 | |||||||
448 | 57339 | 34496 | if (defined($tuple)) { | ||||
449 | 57322 | 42112 | my @tuple = split /-/, $tuple, 4; | ||||
450 | 57322 | 77663 | return @tuple if wantarray; | ||||
451 | return { | ||||||
452 | 3 | 10 | abi => $tuple[0], | ||||
453 | libc => $tuple[1], | ||||||
454 | os => $tuple[2], | ||||||
455 | cpu => $tuple[3], | ||||||
456 | }; | ||||||
457 | } else { | ||||||
458 | 17 | 322 | return; | ||||
459 | } | ||||||
460 | } | ||||||
461 | |||||||
462 - 466 | =item $gnutriplet = debarch_to_gnutriplet($arch) Map a Debian architecture into a GNU triplet. =cut | ||||||
467 | |||||||
468 | sub debarch_to_gnutriplet($) | ||||||
469 | { | ||||||
470 | 8 | 1 | 4 | my $arch = shift; | |||
471 | |||||||
472 | 8 | 6 | return debtuple_to_gnutriplet(debarch_to_debtuple($arch)); | ||||
473 | } | ||||||
474 | |||||||
475 - 479 | =item $arch = gnutriplet_to_debarch($gnutriplet) Map a GNU triplet into a Debian architecture. =cut | ||||||
480 | |||||||
481 | sub gnutriplet_to_debarch($) | ||||||
482 | { | ||||||
483 | 3 | 1 | 3 | my $gnu = shift; | |||
484 | |||||||
485 | 3 | 3 | return debtuple_to_debarch(gnutriplet_to_debtuple($gnu)); | ||||
486 | } | ||||||
487 | |||||||
488 | sub debwildcard_to_debtuple($) | ||||||
489 | { | ||||||
490 | 17445 | 0 | 8620 | my $arch = shift; | |||
491 | 17445 | 12071 | my @tuple = split /-/, $arch, 4; | ||||
492 | |||||||
493 | 17445 27884 | 21284 17524 | if (any { $_ eq 'any' } @tuple) { | ||||
494 | 17145 | 12182 | if (scalar @tuple == 4) { | ||||
495 | 10654 | 13117 | return @tuple; | ||||
496 | } elsif (scalar @tuple == 3) { | ||||||
497 | 4725 | 5673 | return ('any', @tuple); | ||||
498 | } elsif (scalar @tuple == 2) { | ||||||
499 | 1765 | 2097 | return ('any', 'any', @tuple); | ||||
500 | } else { | ||||||
501 | 1 | 2 | return ('any', 'any', 'any', 'any'); | ||||
502 | } | ||||||
503 | } else { | ||||||
504 | 300 | 204 | return debarch_to_debtuple($arch); | ||||
505 | } | ||||||
506 | } | ||||||
507 | |||||||
508 | sub debarch_to_abiattrs($) | ||||||
509 | { | ||||||
510 | 41327 | 0 | 21310 | my $arch = shift; | |||
511 | 41327 | 23310 | my ($abi, $libc, $os, $cpu) = debarch_to_debtuple($arch); | ||||
512 | |||||||
513 | 41327 | 25866 | if (defined($cpu)) { | ||||
514 | 41326 | 29098 | _load_abitable(); | ||||
515 | |||||||
516 | 41326 | 76758 | return ($abibits{$abi} // $cpubits{$cpu}, $cpuendian{$cpu}); | ||||
517 | } else { | ||||||
518 | 1 | 2 | return; | ||||
519 | } | ||||||
520 | } | ||||||
521 | |||||||
522 | sub debarch_to_cpubits($) | ||||||
523 | { | ||||||
524 | 3 | 0 | 3 | my $arch = shift; | |||
525 | 3 | 2 | my (undef, undef, undef, $cpu) = debarch_to_debtuple($arch); | ||||
526 | |||||||
527 | 3 | 3 | if (defined $cpu) { | ||||
528 | 2 | 3 | return $cpubits{$cpu}; | ||||
529 | } else { | ||||||
530 | 1 | 2 | return; | ||||
531 | } | ||||||
532 | } | ||||||
533 | |||||||
534 - 539 | =item $bool = debarch_eq($arch_a, $arch_b) Evaluate the equality of a Debian architecture, by comparing with another Debian architecture. No wildcard matching is performed. =cut | ||||||
540 | |||||||
541 | sub debarch_eq($$) | ||||||
542 | { | ||||||
543 | 10 | 1 | 7 | my ($a, $b) = @_; | |||
544 | |||||||
545 | 10 | 12 | return 1 if ($a eq $b); | ||||
546 | |||||||
547 | 7 | 3 | my @a = debarch_to_debtuple($a); | ||||
548 | 7 | 7 | my @b = debarch_to_debtuple($b); | ||||
549 | |||||||
550 | 7 | 19 | return 0 if scalar @a != 4 or scalar @b != 4; | ||||
551 | |||||||
552 | 3 | 14 | return $a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2] && $a[3] eq $b[3]; | ||||
553 | } | ||||||
554 | |||||||
555 - 560 | =item $bool = debarch_is($arch, $arch_wildcard) Evaluate the identity of a Debian architecture, by matching with an architecture wildcard. =cut | ||||||
561 | |||||||
562 | sub debarch_is($$) | ||||||
563 | { | ||||||
564 | 15171 | 1 | 10122 | my ($real, $alias) = @_; | |||
565 | |||||||
566 | 15171 | 26455 | return 1 if ($alias eq $real or $alias eq 'any'); | ||||
567 | |||||||
568 | 14529 | 9415 | my @real = debarch_to_debtuple($real); | ||||
569 | 14529 | 9995 | my @alias = debwildcard_to_debtuple($alias); | ||||
570 | |||||||
571 | 14529 | 27539 | return 0 if scalar @real != 4 or scalar @alias != 4; | ||||
572 | |||||||
573 | 14526 | 59810 | if (($alias[0] eq $real[0] || $alias[0] eq 'any') && | ||||
574 | ($alias[1] eq $real[1] || $alias[1] eq 'any') && | ||||||
575 | ($alias[2] eq $real[2] || $alias[2] eq 'any') && | ||||||
576 | ($alias[3] eq $real[3] || $alias[3] eq 'any')) { | ||||||
577 | 14227 | 19446 | return 1; | ||||
578 | } | ||||||
579 | |||||||
580 | 299 | 341 | return 0; | ||||
581 | } | ||||||
582 | |||||||
583 - 587 | =item $bool = debarch_is_wildcard($arch) Evaluate whether a Debian architecture is an architecture wildcard. =cut | ||||||
588 | |||||||
589 | sub debarch_is_wildcard($) | ||||||
590 | { | ||||||
591 | 2917 | 1 | 1714 | my $arch = shift; | |||
592 | |||||||
593 | 2917 | 2204 | return 0 if $arch eq 'all'; | ||||
594 | |||||||
595 | 2916 | 1686 | my @tuple = debwildcard_to_debtuple($arch); | ||||
596 | |||||||
597 | 2916 | 3530 | return 0 if scalar @tuple != 4; | ||||
598 | 2915 4009 | 2958 5085 | return 1 if any { $_ eq 'any' } @tuple; | ||||
599 | 1 | 2 | return 0; | ||||
600 | } | ||||||
601 | |||||||
602 - 609 | =item $bool = debarch_is_illegal($arch, %options) Validate an architecture name. If the "positive" option is set to a true value, only positive architectures will be accepted, otherwise negated architectures are allowed. =cut | ||||||
610 | |||||||
611 | sub debarch_is_illegal | ||||||
612 | { | ||||||
613 | 33 | 1 | 26 | my ($arch, %opts) = @_; | |||
614 | 33 | 29 | my $arch_re = qr/[a-zA-Z0-9][a-zA-Z0-9-]*/; | ||||
615 | |||||||
616 | 33 | 22 | if ($opts{positive}) { | ||||
617 | 6 | 24 | return $arch !~ m/^$arch_re$/; | ||||
618 | } else { | ||||||
619 | 27 | 105 | return $arch !~ m/^!?$arch_re$/; | ||||
620 | } | ||||||
621 | } | ||||||
622 | |||||||
623 - 628 | =item $bool = debarch_is_concerned($arch, @arches) Evaluate whether a Debian architecture applies to the list of architecture restrictions, as usually found in dependencies inside square brackets. =cut | ||||||
629 | |||||||
630 | sub debarch_is_concerned | ||||||
631 | { | ||||||
632 | 175 | 1 | 203 | my ($host_arch, @arches) = @_; | |||
633 | |||||||
634 | 175 | 103 | my $seen_arch = 0; | ||||
635 | 175 | 135 | foreach my $arch (@arches) { | ||||
636 | 369 | 222 | $arch = lc $arch; | ||||
637 | |||||||
638 | 369 | 342 | if ($arch =~ /^!/) { | ||||
639 | 221 | 139 | my $not_arch = $arch; | ||||
640 | 221 | 191 | $not_arch =~ s/^!//; | ||||
641 | |||||||
642 | 221 | 164 | if (debarch_is($host_arch, $not_arch)) { | ||||
643 | 44 | 26 | $seen_arch = 0; | ||||
644 | 44 | 32 | last; | ||||
645 | } else { | ||||||
646 | # !arch includes by default all other arches | ||||||
647 | # unless they also appear in a !otherarch | ||||||
648 | 177 | 119 | $seen_arch = 1; | ||||
649 | } | ||||||
650 | } elsif (debarch_is($host_arch, $arch)) { | ||||||
651 | 28 | 15 | $seen_arch = 1; | ||||
652 | 28 | 22 | last; | ||||
653 | } | ||||||
654 | } | ||||||
655 | 175 | 433 | return $seen_arch; | ||||
656 | } | ||||||
657 | |||||||
658 - 665 | =item @array = debarch_list_parse($arch_list, %options) Parse an architecture list. If the "positive" option is set to a true value, only positive architectures will be accepted, otherwise negated architectures are allowed. =cut | ||||||
666 | |||||||
667 | sub debarch_list_parse | ||||||
668 | { | ||||||
669 | 14 | 1 | 11 | my ($arch_list, %opts) = @_; | |||
670 | 14 | 14 | my @arch_list = split ' ', $arch_list; | ||||
671 | |||||||
672 | 14 | 10 | foreach my $arch (@arch_list) { | ||||
673 | 24 | 18 | if (debarch_is_illegal($arch, %opts)) { | ||||
674 | 2 | 19 | error(g_("'%s' is not a legal architecture in list '%s'"), | ||||
675 | $arch, $arch_list); | ||||||
676 | } | ||||||
677 | } | ||||||
678 | |||||||
679 | 12 | 17 | return @arch_list; | ||||
680 | } | ||||||
681 | |||||||
682 | 1; | ||||||
683 | |||||||
684 | =back | ||||||
685 | |||||||
686 - 707 | =head1 CHANGES =head2 Version 1.03 (dpkg 1.19.1) New argument: Accept a "positive" option in debarch_is_illegal() and debarch_list_parse(). =head2 Version 1.02 (dpkg 1.18.19) New import tags: ":all", ":getters", ":parsers", ":mappers", ":operators". =head2 Version 1.01 (dpkg 1.18.5) New functions: debarch_is_illegal(), debarch_list_parse(). =head2 Version 1.00 (dpkg 1.18.2) Mark the module as public. =head1 SEE ALSO dpkg-architecture(1). |