Commit | Line | Data |
---|---|---|
1479465f GJ |
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 | =head1 NAME | |
21 | ||
22 | Dpkg::Arch - handle architectures | |
23 | ||
24 | =head1 DESCRIPTION | |
25 | ||
26 | The Dpkg::Arch module provides functions to handle Debian architectures, | |
27 | wildcards, and mapping from and to GNU triplets. | |
28 | ||
29 | No symbols are exported by default. The :all tag can be used to import all | |
30 | symbols. The :getters, :parsers, :mappers and :operators tags can be used | |
31 | to import specific symbol subsets. | |
32 | ||
33 | =cut | |
34 | ||
35 | use strict; | |
36 | use warnings; | |
37 | use feature qw(state); | |
38 | ||
39 | our $VERSION = '1.02'; | |
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_cpuattrs | |
53 | debarch_to_gnutriplet | |
54 | debarch_to_debtuple | |
55 | debarch_to_multiarch | |
56 | debarch_list_parse | |
57 | debtuple_to_debarch | |
58 | debtuple_to_gnutriplet | |
59 | gnutriplet_to_debarch | |
60 | gnutriplet_to_debtuple | |
61 | gnutriplet_to_multiarch | |
62 | ); | |
63 | our %EXPORT_TAGS = ( | |
64 | all => [ @EXPORT_OK ], | |
65 | getters => [ qw( | |
66 | get_raw_build_arch | |
67 | get_raw_host_arch | |
68 | get_build_arch | |
69 | get_host_arch | |
70 | get_host_gnu_type | |
71 | get_valid_arches | |
72 | ) ], | |
73 | parsers => [ qw( | |
74 | debarch_list_parse | |
75 | ) ], | |
76 | mappers => [ qw( | |
77 | debarch_to_cpuattrs | |
78 | debarch_to_gnutriplet | |
79 | debarch_to_debtuple | |
80 | debarch_to_multiarch | |
81 | debtuple_to_debarch | |
82 | debtuple_to_gnutriplet | |
83 | gnutriplet_to_debarch | |
84 | gnutriplet_to_debtuple | |
85 | gnutriplet_to_multiarch | |
86 | ) ], | |
87 | operators => [ qw( | |
88 | debarch_eq | |
89 | debarch_is | |
90 | debarch_is_wildcard | |
91 | debarch_is_illegal | |
92 | debarch_is_concerned | |
93 | ) ], | |
94 | ); | |
95 | ||
96 | ||
97 | use Exporter qw(import); | |
98 | use POSIX qw(:errno_h); | |
99 | ||
100 | use Dpkg (); | |
101 | use Dpkg::Gettext; | |
102 | use Dpkg::ErrorHandling; | |
103 | use Dpkg::Util qw(:list); | |
104 | 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 | =head1 FUNCTIONS | |
116 | ||
117 | =over 4 | |
118 | ||
119 | =item $arch = get_raw_build_arch() | |
120 | ||
121 | Get the raw build Debian architecture, without taking into account variables | |
122 | from the environment. | |
123 | ||
124 | =cut | |
125 | ||
126 | sub get_raw_build_arch() | |
127 | { | |
128 | state $build_arch; | |
129 | ||
130 | 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 | $build_arch = qx(dpkg --print-architecture); | |
138 | syserr('dpkg --print-architecture failed') if $? >> 8; | |
139 | ||
140 | chomp $build_arch; | |
141 | return $build_arch; | |
142 | } | |
143 | ||
144 | =item $arch = get_build_arch() | |
145 | ||
146 | Get the build Debian architecture, using DEB_BUILD_ARCH from the environment | |
147 | if available. | |
148 | ||
149 | =cut | |
150 | ||
151 | sub get_build_arch() | |
152 | { | |
153 | return Dpkg::Build::Env::get('DEB_BUILD_ARCH') || get_raw_build_arch(); | |
154 | } | |
155 | ||
156 | { | |
157 | my %cc_host_gnu_type; | |
158 | ||
159 | sub get_host_gnu_type() | |
160 | { | |
161 | my $CC = $ENV{CC} || 'gcc'; | |
162 | ||
163 | return $cc_host_gnu_type{$CC} if defined $cc_host_gnu_type{$CC}; | |
164 | ||
165 | $cc_host_gnu_type{$CC} = qx($CC -dumpmachine); | |
166 | if ($? >> 8) { | |
167 | $cc_host_gnu_type{$CC} = ''; | |
168 | } else { | |
169 | chomp $cc_host_gnu_type{$CC}; | |
170 | } | |
171 | ||
172 | return $cc_host_gnu_type{$CC}; | |
173 | } | |
174 | ||
175 | sub set_host_gnu_type | |
176 | { | |
177 | my ($host_gnu_type) = @_; | |
178 | my $CC = $ENV{CC} || 'gcc'; | |
179 | ||
180 | $cc_host_gnu_type{$CC} = $host_gnu_type; | |
181 | } | |
182 | } | |
183 | ||
184 | =item $arch = get_raw_host_arch() | |
185 | ||
186 | Get the raw host Debian architecture, without taking into account variables | |
187 | from the environment. | |
188 | ||
189 | =cut | |
190 | ||
191 | sub get_raw_host_arch() | |
192 | { | |
193 | state $host_arch; | |
194 | ||
195 | return $host_arch if defined $host_arch; | |
196 | ||
197 | my $host_gnu_type = get_host_gnu_type(); | |
198 | ||
199 | if ($host_gnu_type eq '') { | |
200 | warning(g_('cannot determine CC system type, falling back to ' . | |
201 | 'default (native compilation)')); | |
202 | } else { | |
203 | my (@host_archtuple) = gnutriplet_to_debtuple($host_gnu_type); | |
204 | $host_arch = debtuple_to_debarch(@host_archtuple); | |
205 | ||
206 | if (defined $host_arch) { | |
207 | $host_gnu_type = debtuple_to_gnutriplet(@host_archtuple); | |
208 | } else { | |
209 | warning(g_('unknown CC system type %s, falling back to ' . | |
210 | 'default (native compilation)'), $host_gnu_type); | |
211 | $host_gnu_type = ''; | |
212 | } | |
213 | set_host_gnu_type($host_gnu_type); | |
214 | } | |
215 | ||
216 | if (!defined($host_arch)) { | |
217 | # Switch to native compilation. | |
218 | $host_arch = get_raw_build_arch(); | |
219 | } | |
220 | ||
221 | return $host_arch; | |
222 | } | |
223 | ||
224 | =item $arch = get_host_arch() | |
225 | ||
226 | Get the host Debian architecture, using DEB_HOST_ARCH from the environment | |
227 | if available. | |
228 | ||
229 | =cut | |
230 | ||
231 | sub get_host_arch() | |
232 | { | |
233 | return Dpkg::Build::Env::get('DEB_HOST_ARCH') || get_raw_host_arch(); | |
234 | } | |
235 | ||
236 | =item @arch_list = get_valid_arches() | |
237 | ||
238 | Get an array with all currently known Debian architectures. | |
239 | ||
240 | =cut | |
241 | ||
242 | sub get_valid_arches() | |
243 | { | |
244 | _load_cputable(); | |
245 | _load_ostable(); | |
246 | ||
247 | my @arches; | |
248 | ||
249 | foreach my $os (@os) { | |
250 | foreach my $cpu (@cpu) { | |
251 | my $arch = debtuple_to_debarch(split(/-/, $os, 3), $cpu); | |
252 | push @arches, $arch if defined($arch); | |
253 | } | |
254 | } | |
255 | ||
256 | return @arches; | |
257 | } | |
258 | ||
259 | my %table_loaded; | |
260 | sub _load_table | |
261 | { | |
262 | my ($table, $loader) = @_; | |
263 | ||
264 | return if $table_loaded{$table}; | |
265 | ||
266 | local $_; | |
267 | local $/ = "\n"; | |
268 | ||
269 | open my $table_fh, '<', "$Dpkg::DATADIR/$table" | |
270 | or syserr(g_('cannot open %s'), $table); | |
271 | while (<$table_fh>) { | |
272 | $loader->($_); | |
273 | } | |
274 | close $table_fh; | |
275 | ||
276 | $table_loaded{$table} = 1; | |
277 | } | |
278 | ||
279 | sub _load_cputable | |
280 | { | |
281 | _load_table('cputable', sub { | |
282 | if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) { | |
283 | $cputable{$1} = $2; | |
284 | $cputable_re{$1} = $3; | |
285 | $cpubits{$1} = $4; | |
286 | $cpuendian{$1} = $5; | |
287 | push @cpu, $1; | |
288 | } | |
289 | }); | |
290 | } | |
291 | ||
292 | sub _load_ostable | |
293 | { | |
294 | _load_table('ostable', sub { | |
295 | if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) { | |
296 | $ostable{$1} = $2; | |
297 | $ostable_re{$1} = $3; | |
298 | push @os, $1; | |
299 | } | |
300 | }); | |
301 | } | |
302 | ||
303 | sub _load_abitable() | |
304 | { | |
305 | _load_table('abitable', sub { | |
306 | if (m/^(?!\#)(\S+)\s+(\S+)/) { | |
307 | $abibits{$1} = $2; | |
308 | } | |
309 | }); | |
310 | } | |
311 | ||
312 | sub _load_tupletable() | |
313 | { | |
314 | _load_cputable(); | |
315 | ||
316 | _load_table('tupletable', sub { | |
317 | if (m/^(?!\#)(\S+)\s+(\S+)/) { | |
318 | my $debtuple = $1; | |
319 | my $debarch = $2; | |
320 | ||
321 | if ($debtuple =~ /<cpu>/) { | |
322 | foreach my $_cpu (@cpu) { | |
323 | (my $dt = $debtuple) =~ s/<cpu>/$_cpu/; | |
324 | (my $da = $debarch) =~ s/<cpu>/$_cpu/; | |
325 | ||
326 | next if exists $debarch_to_debtuple{$da} | |
327 | or exists $debtuple_to_debarch{$dt}; | |
328 | ||
329 | $debarch_to_debtuple{$da} = $dt; | |
330 | $debtuple_to_debarch{$dt} = $da; | |
331 | } | |
332 | } else { | |
333 | $debarch_to_debtuple{$2} = $1; | |
334 | $debtuple_to_debarch{$1} = $2; | |
335 | } | |
336 | } | |
337 | }); | |
338 | } | |
339 | ||
340 | sub debtuple_to_gnutriplet(@) | |
341 | { | |
342 | my ($abi, $libc, $os, $cpu) = @_; | |
343 | ||
344 | _load_cputable(); | |
345 | _load_ostable(); | |
346 | ||
347 | return unless | |
348 | defined $abi && defined $libc && defined $os && defined $cpu && | |
349 | exists $cputable{$cpu} && exists $ostable{"$abi-$libc-$os"}; | |
350 | return join('-', $cputable{$cpu}, $ostable{"$abi-$libc-$os"}); | |
351 | } | |
352 | ||
353 | sub gnutriplet_to_debtuple($) | |
354 | { | |
355 | my $gnu = shift; | |
356 | return unless defined($gnu); | |
357 | my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2); | |
358 | return unless defined($gnu_cpu) && defined($gnu_os); | |
359 | ||
360 | _load_cputable(); | |
361 | _load_ostable(); | |
362 | ||
363 | my ($os, $cpu); | |
364 | ||
365 | foreach my $_cpu (@cpu) { | |
366 | if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) { | |
367 | $cpu = $_cpu; | |
368 | last; | |
369 | } | |
370 | } | |
371 | ||
372 | foreach my $_os (@os) { | |
373 | if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) { | |
374 | $os = $_os; | |
375 | last; | |
376 | } | |
377 | } | |
378 | ||
379 | return if !defined($cpu) || !defined($os); | |
380 | return (split(/-/, $os, 3), $cpu); | |
381 | } | |
382 | ||
383 | =item $multiarch = gnutriplet_to_multiarch($gnutriplet) | |
384 | ||
385 | Map a GNU triplet into a Debian multiarch triplet. | |
386 | ||
387 | =cut | |
388 | ||
389 | sub gnutriplet_to_multiarch($) | |
390 | { | |
391 | my $gnu = shift; | |
392 | my ($cpu, $cdr) = split(/-/, $gnu, 2); | |
393 | ||
394 | if ($cpu =~ /^i[4567]86$/) { | |
395 | return "i386-$cdr"; | |
396 | } else { | |
397 | return $gnu; | |
398 | } | |
399 | } | |
400 | ||
401 | =item $multiarch = debarch_to_multiarch($arch) | |
402 | ||
403 | Map a Debian architecture into a Debian multiarch triplet. | |
404 | ||
405 | =cut | |
406 | ||
407 | sub debarch_to_multiarch($) | |
408 | { | |
409 | my $arch = shift; | |
410 | ||
411 | return gnutriplet_to_multiarch(debarch_to_gnutriplet($arch)); | |
412 | } | |
413 | ||
414 | sub debtuple_to_debarch(@) | |
415 | { | |
416 | my ($abi, $libc, $os, $cpu) = @_; | |
417 | ||
418 | _load_tupletable(); | |
419 | ||
420 | if (!defined $abi || !defined $libc || !defined $os || !defined $cpu) { | |
421 | return; | |
422 | } elsif (exists $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}) { | |
423 | return $debtuple_to_debarch{"$abi-$libc-$os-$cpu"}; | |
424 | } else { | |
425 | return; | |
426 | } | |
427 | } | |
428 | ||
429 | sub debarch_to_debtuple($) | |
430 | { | |
431 | my $arch = shift; | |
432 | ||
433 | return if not defined $arch; | |
434 | ||
435 | _load_tupletable(); | |
436 | ||
437 | if ($arch =~ /^linux-([^-]*)/) { | |
438 | # XXX: Might disappear in the future, not sure yet. | |
439 | $arch = $1; | |
440 | } | |
441 | ||
442 | my $tuple = $debarch_to_debtuple{$arch}; | |
443 | ||
444 | if (defined($tuple)) { | |
445 | my @tuple = split /-/, $tuple, 4; | |
446 | return @tuple if wantarray; | |
447 | return { | |
448 | abi => $tuple[0], | |
449 | libc => $tuple[1], | |
450 | os => $tuple[2], | |
451 | cpu => $tuple[3], | |
452 | }; | |
453 | } else { | |
454 | return; | |
455 | } | |
456 | } | |
457 | ||
458 | =item $gnutriplet = debarch_to_gnutriplet($arch) | |
459 | ||
460 | Map a Debian architecture into a GNU triplet. | |
461 | ||
462 | =cut | |
463 | ||
464 | sub debarch_to_gnutriplet($) | |
465 | { | |
466 | my $arch = shift; | |
467 | ||
468 | return debtuple_to_gnutriplet(debarch_to_debtuple($arch)); | |
469 | } | |
470 | ||
471 | =item $arch = gnutriplet_to_debarch($gnutriplet) | |
472 | ||
473 | Map a GNU triplet into a Debian architecture. | |
474 | ||
475 | =cut | |
476 | ||
477 | sub gnutriplet_to_debarch($) | |
478 | { | |
479 | my $gnu = shift; | |
480 | ||
481 | return debtuple_to_debarch(gnutriplet_to_debtuple($gnu)); | |
482 | } | |
483 | ||
484 | sub debwildcard_to_debtuple($) | |
485 | { | |
486 | my $arch = shift; | |
487 | my @tuple = split /-/, $arch, 4; | |
488 | ||
489 | if (any { $_ eq 'any' } @tuple) { | |
490 | if (scalar @tuple == 4) { | |
491 | return @tuple; | |
492 | } elsif (scalar @tuple == 3) { | |
493 | return ('any', @tuple); | |
494 | } elsif (scalar @tuple == 2) { | |
495 | return ('any', 'any', @tuple); | |
496 | } else { | |
497 | return ('any', 'any', 'any', 'any'); | |
498 | } | |
499 | } else { | |
500 | return debarch_to_debtuple($arch); | |
501 | } | |
502 | } | |
503 | ||
504 | sub debarch_to_cpuattrs($) | |
505 | { | |
506 | my $arch = shift; | |
507 | my ($abi, $libc, $os, $cpu) = debarch_to_debtuple($arch); | |
508 | ||
509 | if (defined($cpu)) { | |
510 | _load_abitable(); | |
511 | ||
512 | return ($abibits{$abi} // $cpubits{$cpu}, $cpuendian{$cpu}); | |
513 | } else { | |
514 | return; | |
515 | } | |
516 | } | |
517 | ||
518 | =item $bool = debarch_eq($arch_a, $arch_b) | |
519 | ||
520 | Evaluate the equality of a Debian architecture, by comparing with another | |
521 | Debian architecture. No wildcard matching is performed. | |
522 | ||
523 | =cut | |
524 | ||
525 | sub debarch_eq($$) | |
526 | { | |
527 | my ($a, $b) = @_; | |
528 | ||
529 | return 1 if ($a eq $b); | |
530 | ||
531 | my @a = debarch_to_debtuple($a); | |
532 | my @b = debarch_to_debtuple($b); | |
533 | ||
534 | return 0 if scalar @a != 4 or scalar @b != 4; | |
535 | ||
536 | return $a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2] && $a[3] eq $b[3]; | |
537 | } | |
538 | ||
539 | =item $bool = debarch_is($arch, $arch_wildcard) | |
540 | ||
541 | Evaluate the identity of a Debian architecture, by matching with an | |
542 | architecture wildcard. | |
543 | ||
544 | =cut | |
545 | ||
546 | sub debarch_is($$) | |
547 | { | |
548 | my ($real, $alias) = @_; | |
549 | ||
550 | return 1 if ($alias eq $real or $alias eq 'any'); | |
551 | ||
552 | my @real = debarch_to_debtuple($real); | |
553 | my @alias = debwildcard_to_debtuple($alias); | |
554 | ||
555 | return 0 if scalar @real != 4 or scalar @alias != 4; | |
556 | ||
557 | if (($alias[0] eq $real[0] || $alias[0] eq 'any') && | |
558 | ($alias[1] eq $real[1] || $alias[1] eq 'any') && | |
559 | ($alias[2] eq $real[2] || $alias[2] eq 'any') && | |
560 | ($alias[3] eq $real[3] || $alias[3] eq 'any')) { | |
561 | return 1; | |
562 | } | |
563 | ||
564 | return 0; | |
565 | } | |
566 | ||
567 | =item $bool = debarch_is_wildcard($arch) | |
568 | ||
569 | Evaluate whether a Debian architecture is an architecture wildcard. | |
570 | ||
571 | =cut | |
572 | ||
573 | sub debarch_is_wildcard($) | |
574 | { | |
575 | my $arch = shift; | |
576 | ||
577 | return 0 if $arch eq 'all'; | |
578 | ||
579 | my @tuple = debwildcard_to_debtuple($arch); | |
580 | ||
581 | return 0 if scalar @tuple != 4; | |
582 | return 1 if any { $_ eq 'any' } @tuple; | |
583 | return 0; | |
584 | } | |
585 | ||
586 | =item $bool = debarch_is_illegal($arch) | |
587 | ||
588 | Validate an architecture name. | |
589 | ||
590 | =cut | |
591 | ||
592 | sub debarch_is_illegal | |
593 | { | |
594 | my ($arch) = @_; | |
595 | ||
596 | return $arch !~ m/^!?[a-zA-Z0-9][a-zA-Z0-9-]*$/; | |
597 | } | |
598 | ||
599 | =item $bool = debarch_is_concerned($arch, @arches) | |
600 | ||
601 | Evaluate whether a Debian architecture applies to the list of architecture | |
602 | restrictions, as usually found in dependencies inside square brackets. | |
603 | ||
604 | =cut | |
605 | ||
606 | sub debarch_is_concerned | |
607 | { | |
608 | my ($host_arch, @arches) = @_; | |
609 | ||
610 | my $seen_arch = 0; | |
611 | foreach my $arch (@arches) { | |
612 | $arch = lc $arch; | |
613 | ||
614 | if ($arch =~ /^!/) { | |
615 | my $not_arch = $arch; | |
616 | $not_arch =~ s/^!//; | |
617 | ||
618 | if (debarch_is($host_arch, $not_arch)) { | |
619 | $seen_arch = 0; | |
620 | last; | |
621 | } else { | |
622 | # !arch includes by default all other arches | |
623 | # unless they also appear in a !otherarch | |
624 | $seen_arch = 1; | |
625 | } | |
626 | } elsif (debarch_is($host_arch, $arch)) { | |
627 | $seen_arch = 1; | |
628 | last; | |
629 | } | |
630 | } | |
631 | return $seen_arch; | |
632 | } | |
633 | ||
634 | =item @array = debarch_list_parse($arch_list, %options) | |
635 | ||
636 | Parse an architecture list. | |
637 | ||
638 | =cut | |
639 | ||
640 | sub debarch_list_parse | |
641 | { | |
642 | my $arch_list = shift; | |
643 | my @arch_list = split /\s+/, $arch_list; | |
644 | ||
645 | foreach my $arch (@arch_list) { | |
646 | if (debarch_is_illegal($arch)) { | |
647 | error(g_("'%s' is not a legal architecture in list '%s'"), | |
648 | $arch, $arch_list); | |
649 | } | |
650 | } | |
651 | ||
652 | return @arch_list; | |
653 | } | |
654 | ||
655 | 1; | |
656 | ||
657 | __END__ | |
658 | ||
659 | =back | |
660 | ||
661 | =head1 CHANGES | |
662 | ||
663 | =head2 Version 1.02 (dpkg 1.18.19) | |
664 | ||
665 | New import tags: ":all", ":getters", ":parsers", ":mappers", ":operators". | |
666 | ||
667 | =head2 Version 1.01 (dpkg 1.18.5) | |
668 | ||
669 | New functions: debarch_is_illegal(), debarch_list_parse(). | |
670 | ||
671 | =head2 Version 1.00 (dpkg 1.18.2) | |
672 | ||
673 | Mark the module as public. | |
674 | ||
675 | =head1 SEE ALSO | |
676 | ||
677 | dpkg-architecture(1). |