OLD | NEW |
| (Empty) |
1 # Copyright © 2006-2013 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 use strict; | |
19 use warnings; | |
20 | |
21 our $VERSION = '0.01'; | |
22 | |
23 use Exporter qw(import); | |
24 our @EXPORT_OK = qw(get_raw_build_arch get_raw_host_arch | |
25 get_build_arch get_host_arch get_gcc_host_gnu_type | |
26 get_valid_arches debarch_eq debarch_is debarch_is_wildcard | |
27 debarch_to_cpuattrs | |
28 debarch_to_gnutriplet gnutriplet_to_debarch | |
29 debtriplet_to_gnutriplet gnutriplet_to_debtriplet | |
30 debtriplet_to_debarch debarch_to_debtriplet | |
31 gnutriplet_to_multiarch debarch_to_multiarch); | |
32 | |
33 use POSIX qw(:errno_h); | |
34 use Dpkg (); | |
35 use Dpkg::Gettext; | |
36 use Dpkg::ErrorHandling; | |
37 use Dpkg::Util qw(:list); | |
38 use Dpkg::BuildEnv; | |
39 | |
40 my (@cpu, @os); | |
41 my (%cputable, %ostable); | |
42 my (%cputable_re, %ostable_re); | |
43 my (%cpubits, %cpuendian); | |
44 my %abibits; | |
45 | |
46 my %debtriplet_to_debarch; | |
47 my %debarch_to_debtriplet; | |
48 | |
49 { | |
50 my $build_arch; | |
51 my $host_arch; | |
52 my $gcc_host_gnu_type; | |
53 | |
54 sub get_raw_build_arch() | |
55 { | |
56 return $build_arch if defined $build_arch; | |
57 | |
58 # Note: We *always* require an installed dpkg when inferring the | |
59 # build architecture. The bootstrapping case is handled by | |
60 # dpkg-architecture itself, by avoiding computing the DEB_BUILD_ | |
61 # variables when they are not requested. | |
62 | |
63 $build_arch = `dpkg --print-architecture`; | |
64 syserr('dpkg --print-architecture failed') if $? >> 8; | |
65 | |
66 chomp $build_arch; | |
67 return $build_arch; | |
68 } | |
69 | |
70 sub get_build_arch() | |
71 { | |
72 return Dpkg::BuildEnv::get('DEB_BUILD_ARCH') || get_raw_build_arch(); | |
73 } | |
74 | |
75 sub get_gcc_host_gnu_type() | |
76 { | |
77 return $gcc_host_gnu_type if defined $gcc_host_gnu_type; | |
78 | |
79 $gcc_host_gnu_type = `\${CC:-gcc} -dumpmachine`; | |
80 if ($? >> 8) { | |
81 $gcc_host_gnu_type = ''; | |
82 } else { | |
83 chomp $gcc_host_gnu_type; | |
84 } | |
85 | |
86 return $gcc_host_gnu_type; | |
87 } | |
88 | |
89 sub get_raw_host_arch() | |
90 { | |
91 return $host_arch if defined $host_arch; | |
92 | |
93 $gcc_host_gnu_type = get_gcc_host_gnu_type(); | |
94 | |
95 if ($gcc_host_gnu_type eq '') { | |
96 warning(_g("couldn't determine gcc system type, falling back to " . | |
97 'default (native compilation)')); | |
98 } else { | |
99 my (@host_archtriplet) = gnutriplet_to_debtriplet($gcc_host_gnu_type
); | |
100 $host_arch = debtriplet_to_debarch(@host_archtriplet); | |
101 | |
102 if (defined $host_arch) { | |
103 $gcc_host_gnu_type = debtriplet_to_gnutriplet(@host_archtriplet)
; | |
104 } else { | |
105 warning(_g('unknown gcc system type %s, falling back to ' . | |
106 'default (native compilation)'), $gcc_host_gnu_type); | |
107 $gcc_host_gnu_type = ''; | |
108 } | |
109 } | |
110 | |
111 if (!defined($host_arch)) { | |
112 # Switch to native compilation. | |
113 $host_arch = get_raw_build_arch(); | |
114 } | |
115 | |
116 return $host_arch; | |
117 } | |
118 | |
119 sub get_host_arch() | |
120 { | |
121 return Dpkg::BuildEnv::get('DEB_HOST_ARCH') || get_raw_host_arch(); | |
122 } | |
123 } | |
124 | |
125 sub get_valid_arches() | |
126 { | |
127 read_cputable(); | |
128 read_ostable(); | |
129 | |
130 my @arches; | |
131 | |
132 foreach my $os (@os) { | |
133 foreach my $cpu (@cpu) { | |
134 my $arch = debtriplet_to_debarch(split(/-/, $os, 2), $cpu); | |
135 push @arches, $arch if defined($arch); | |
136 } | |
137 } | |
138 | |
139 return @arches; | |
140 } | |
141 | |
142 my $cputable_loaded = 0; | |
143 sub read_cputable | |
144 { | |
145 return if ($cputable_loaded); | |
146 | |
147 local $_; | |
148 local $/ = "\n"; | |
149 | |
150 open my $cputable_fh, '<', "$Dpkg::DATADIR/cputable" | |
151 or syserr(_g('cannot open %s'), 'cputable'); | |
152 while (<$cputable_fh>) { | |
153 if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) { | |
154 $cputable{$1} = $2; | |
155 $cputable_re{$1} = $3; | |
156 $cpubits{$1} = $4; | |
157 $cpuendian{$1} = $5; | |
158 push @cpu, $1; | |
159 } | |
160 } | |
161 close $cputable_fh; | |
162 | |
163 $cputable_loaded = 1; | |
164 } | |
165 | |
166 my $ostable_loaded = 0; | |
167 sub read_ostable | |
168 { | |
169 return if ($ostable_loaded); | |
170 | |
171 local $_; | |
172 local $/ = "\n"; | |
173 | |
174 open my $ostable_fh, '<', "$Dpkg::DATADIR/ostable" | |
175 or syserr(_g('cannot open %s'), 'ostable'); | |
176 while (<$ostable_fh>) { | |
177 if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) { | |
178 $ostable{$1} = $2; | |
179 $ostable_re{$1} = $3; | |
180 push @os, $1; | |
181 } | |
182 } | |
183 close $ostable_fh; | |
184 | |
185 $ostable_loaded = 1; | |
186 } | |
187 | |
188 my $abitable_loaded = 0; | |
189 sub abitable_load() | |
190 { | |
191 return if ($abitable_loaded); | |
192 | |
193 local $_; | |
194 local $/ = "\n"; | |
195 | |
196 # Because the abitable is only for override information, do not fail if | |
197 # it does not exist, as that will only mean the other tables do not have | |
198 # an entry needing to be overridden. This way we do not require a newer | |
199 # dpkg by libdpkg-perl. | |
200 if (open my $abitable_fh, '<', "$Dpkg::DATADIR/abitable") { | |
201 while (<$abitable_fh>) { | |
202 if (m/^(?!\#)(\S+)\s+(\S+)/) { | |
203 $abibits{$1} = $2; | |
204 } | |
205 } | |
206 close $abitable_fh; | |
207 } elsif ($! != ENOENT) { | |
208 syserr(_g('cannot open %s'), 'abitable'); | |
209 } | |
210 | |
211 $abitable_loaded = 1; | |
212 } | |
213 | |
214 my $triplettable_loaded = 0; | |
215 sub read_triplettable() | |
216 { | |
217 return if ($triplettable_loaded); | |
218 | |
219 read_cputable(); | |
220 | |
221 local $_; | |
222 local $/ = "\n"; | |
223 | |
224 open my $triplettable_fh, '<', "$Dpkg::DATADIR/triplettable" | |
225 or syserr(_g('cannot open %s'), 'triplettable'); | |
226 while (<$triplettable_fh>) { | |
227 if (m/^(?!\#)(\S+)\s+(\S+)/) { | |
228 my $debtriplet = $1; | |
229 my $debarch = $2; | |
230 | |
231 if ($debtriplet =~ /<cpu>/) { | |
232 foreach my $_cpu (@cpu) { | |
233 (my $dt = $debtriplet) =~ s/<cpu>/$_cpu/; | |
234 (my $da = $debarch) =~ s/<cpu>/$_cpu/; | |
235 | |
236 next if exists $debarch_to_debtriplet{$da} | |
237 or exists $debtriplet_to_debarch{$dt}; | |
238 | |
239 $debarch_to_debtriplet{$da} = $dt; | |
240 $debtriplet_to_debarch{$dt} = $da; | |
241 } | |
242 } else { | |
243 $debarch_to_debtriplet{$2} = $1; | |
244 $debtriplet_to_debarch{$1} = $2; | |
245 } | |
246 } | |
247 } | |
248 close $triplettable_fh; | |
249 | |
250 $triplettable_loaded = 1; | |
251 } | |
252 | |
253 sub debtriplet_to_gnutriplet(@) | |
254 { | |
255 my ($abi, $os, $cpu) = @_; | |
256 | |
257 read_cputable(); | |
258 read_ostable(); | |
259 | |
260 return unless defined($abi) && defined($os) && defined($cpu) && | |
261 exists($cputable{$cpu}) && exists($ostable{"$abi-$os"}); | |
262 return join('-', $cputable{$cpu}, $ostable{"$abi-$os"}); | |
263 } | |
264 | |
265 sub gnutriplet_to_debtriplet($) | |
266 { | |
267 my ($gnu) = @_; | |
268 return unless defined($gnu); | |
269 my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2); | |
270 return unless defined($gnu_cpu) && defined($gnu_os); | |
271 | |
272 read_cputable(); | |
273 read_ostable(); | |
274 | |
275 my ($os, $cpu); | |
276 | |
277 foreach my $_cpu (@cpu) { | |
278 if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) { | |
279 $cpu = $_cpu; | |
280 last; | |
281 } | |
282 } | |
283 | |
284 foreach my $_os (@os) { | |
285 if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) { | |
286 $os = $_os; | |
287 last; | |
288 } | |
289 } | |
290 | |
291 return if !defined($cpu) || !defined($os); | |
292 return (split(/-/, $os, 2), $cpu); | |
293 } | |
294 | |
295 sub gnutriplet_to_multiarch($) | |
296 { | |
297 my ($gnu) = @_; | |
298 my ($cpu, $cdr) = split(/-/, $gnu, 2); | |
299 | |
300 if ($cpu =~ /^i[456]86$/) { | |
301 return "i386-$cdr"; | |
302 } else { | |
303 return $gnu; | |
304 } | |
305 } | |
306 | |
307 sub debarch_to_multiarch($) | |
308 { | |
309 my ($arch) = @_; | |
310 | |
311 return gnutriplet_to_multiarch(debarch_to_gnutriplet($arch)); | |
312 } | |
313 | |
314 sub debtriplet_to_debarch(@) | |
315 { | |
316 my ($abi, $os, $cpu) = @_; | |
317 | |
318 read_triplettable(); | |
319 | |
320 if (!defined($abi) || !defined($os) || !defined($cpu)) { | |
321 return; | |
322 } elsif (exists $debtriplet_to_debarch{"$abi-$os-$cpu"}) { | |
323 return $debtriplet_to_debarch{"$abi-$os-$cpu"}; | |
324 } else { | |
325 return; | |
326 } | |
327 } | |
328 | |
329 sub debarch_to_debtriplet($) | |
330 { | |
331 local ($_) = @_; | |
332 my $arch; | |
333 | |
334 read_triplettable(); | |
335 | |
336 if (/^linux-([^-]*)/) { | |
337 # XXX: Might disappear in the future, not sure yet. | |
338 $arch = $1; | |
339 } else { | |
340 $arch = $_; | |
341 } | |
342 | |
343 my $triplet = $debarch_to_debtriplet{$arch}; | |
344 | |
345 if (defined($triplet)) { | |
346 return split(/-/, $triplet, 3); | |
347 } else { | |
348 return; | |
349 } | |
350 } | |
351 | |
352 sub debarch_to_gnutriplet($) | |
353 { | |
354 my ($arch) = @_; | |
355 | |
356 return debtriplet_to_gnutriplet(debarch_to_debtriplet($arch)); | |
357 } | |
358 | |
359 sub gnutriplet_to_debarch($) | |
360 { | |
361 my ($gnu) = @_; | |
362 | |
363 return debtriplet_to_debarch(gnutriplet_to_debtriplet($gnu)); | |
364 } | |
365 | |
366 sub debwildcard_to_debtriplet($) | |
367 { | |
368 my ($arch) = @_; | |
369 my @tuple = split /-/, $arch, 3; | |
370 | |
371 if (any { $_ eq 'any' } @tuple) { | |
372 if (scalar @tuple == 3) { | |
373 return @tuple; | |
374 } elsif (scalar @tuple == 2) { | |
375 return ('any', @tuple); | |
376 } else { | |
377 return ('any', 'any', 'any'); | |
378 } | |
379 } else { | |
380 return debarch_to_debtriplet($arch); | |
381 } | |
382 } | |
383 | |
384 sub debarch_to_cpuattrs($) | |
385 { | |
386 my ($arch) = @_; | |
387 my ($abi, $os, $cpu) = debarch_to_debtriplet($arch); | |
388 | |
389 if (defined($cpu)) { | |
390 abitable_load(); | |
391 | |
392 return ($abibits{$abi} || $cpubits{$cpu}, $cpuendian{$cpu}); | |
393 } else { | |
394 return; | |
395 } | |
396 } | |
397 | |
398 sub debarch_eq($$) | |
399 { | |
400 my ($a, $b) = @_; | |
401 | |
402 return 1 if ($a eq $b); | |
403 | |
404 my @a = debarch_to_debtriplet($a); | |
405 my @b = debarch_to_debtriplet($b); | |
406 | |
407 return 0 if scalar @a != 3 or scalar @b != 3; | |
408 | |
409 return ($a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2]); | |
410 } | |
411 | |
412 sub debarch_is($$) | |
413 { | |
414 my ($real, $alias) = @_; | |
415 | |
416 return 1 if ($alias eq $real or $alias eq 'any'); | |
417 | |
418 my @real = debarch_to_debtriplet($real); | |
419 my @alias = debwildcard_to_debtriplet($alias); | |
420 | |
421 return 0 if scalar @real != 3 or scalar @alias != 3; | |
422 | |
423 if (($alias[0] eq $real[0] || $alias[0] eq 'any') && | |
424 ($alias[1] eq $real[1] || $alias[1] eq 'any') && | |
425 ($alias[2] eq $real[2] || $alias[2] eq 'any')) { | |
426 return 1; | |
427 } | |
428 | |
429 return 0; | |
430 } | |
431 | |
432 sub debarch_is_wildcard($) | |
433 { | |
434 my ($arch) = @_; | |
435 | |
436 return 0 if $arch eq 'all'; | |
437 | |
438 my @triplet = debwildcard_to_debtriplet($arch); | |
439 | |
440 return 0 if scalar @triplet != 3; | |
441 return 1 if any { $_ eq 'any' } @triplet; | |
442 return 0; | |
443 } | |
444 | |
445 1; | |
OLD | NEW |