Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | #!/usr/bin/perl |
2 | # | |
3 | # dpkg-architecture | |
4 | # | |
5 | # Copyright © 1999-2001 Marcus Brinkmann <brinkmd@debian.org> | |
6 | # Copyright © 2004-2005 Scott James Remnant <scott@netsplit.com>, | |
7 | # Copyright © 2006-2014 Guillem Jover <guillem@debian.org> | |
8 | # | |
9 | # This program is free software; you can redistribute it and/or modify | |
10 | # it under the terms of the GNU General Public License as published by | |
11 | # the Free Software Foundation; either version 2 of the License, or | |
12 | # (at your option) any later version. | |
13 | # | |
14 | # This program is distributed in the hope that it will be useful, | |
15 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | # GNU General Public License for more details. | |
18 | # | |
19 | # You should have received a copy of the GNU General Public License | |
20 | # along with this program. If not, see <https://www.gnu.org/licenses/>. | |
21 | ||
22 | use strict; | |
23 | use warnings; | |
24 | ||
25 | use Dpkg (); | |
26 | use Dpkg::Gettext; | |
27 | use Dpkg::Getopt; | |
28 | use Dpkg::ErrorHandling; | |
29 | use Dpkg::Arch qw(:getters :mappers debarch_eq debarch_is); | |
30 | ||
31 | textdomain('dpkg-dev'); | |
32 | ||
33 | sub version { | |
34 | printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION; | |
35 | ||
36 | printf g_(' | |
37 | This is free software; see the GNU General Public License version 2 or | |
38 | later for copying conditions. There is NO warranty. | |
39 | '); | |
40 | } | |
41 | ||
42 | sub usage { | |
43 | printf g_( | |
44 | 'Usage: %s [<option>...] [<command>]') | |
45 | . "\n\n" . g_( | |
46 | 'Commands: | |
47 | -l, --list list variables (default). | |
48 | -L, --list-known list valid architectures (matching some criteria). | |
49 | -e, --equal <arch> compare with host Debian architecture. | |
50 | -i, --is <arch-wildcard> match against host Debian architecture. | |
51 | -q, --query <variable> prints only the value of <variable>. | |
52 | -s, --print-set print command to set environment variables. | |
53 | -u, --print-unset print command to unset environment variables. | |
54 | -c, --command <command> set environment and run the command in it. | |
55 | -?, --help show this help message. | |
56 | --version show the version.') | |
57 | . "\n\n" . g_( | |
58 | 'Options: | |
59 | -a, --host-arch <arch> set host Debian architecture. | |
60 | -t, --host-type <type> set host GNU system type. | |
61 | -A, --target-arch <arch> set target Debian architecture. | |
62 | -T, --target-type <type> set target GNU system type. | |
63 | -W, --match-wildcard <arch-wildcard> | |
64 | restrict architecture list matching <arch-wildcard>. | |
65 | -B, --match-bits <arch-bits> | |
66 | restrict architecture list matching <arch-bits>. | |
67 | -E, --match-endian <arch-endian> | |
68 | restrict architecture list matching <arch-endian>. | |
69 | -f, --force force flag (override variables set in environment).') | |
70 | . "\n", $Dpkg::PROGNAME; | |
71 | } | |
72 | ||
73 | sub check_arch_coherency | |
74 | { | |
75 | my ($arch, $gnu_type) = @_; | |
76 | ||
77 | if ($arch ne '' && $gnu_type eq '') { | |
78 | $gnu_type = debarch_to_gnutriplet($arch); | |
79 | error(g_('unknown Debian architecture %s, you must specify ' . | |
80 | 'GNU system type, too'), $arch) | |
81 | unless defined $gnu_type; | |
82 | } | |
83 | ||
84 | if ($gnu_type ne '' && $arch eq '') { | |
85 | $arch = gnutriplet_to_debarch($gnu_type); | |
86 | error(g_('unknown GNU system type %s, you must specify ' . | |
87 | 'Debian architecture, too'), $gnu_type) | |
88 | unless defined $arch; | |
89 | } | |
90 | ||
91 | if ($gnu_type ne '' && $arch ne '') { | |
92 | my $dfl_gnu_type = debarch_to_gnutriplet($arch); | |
93 | error(g_('unknown default GNU system type for Debian architecture %s'), | |
94 | $arch) | |
95 | unless defined $dfl_gnu_type; | |
96 | warning(g_('default GNU system type %s for Debian arch %s does not ' . | |
97 | 'match specified GNU system type %s'), $dfl_gnu_type, | |
98 | $arch, $gnu_type) | |
99 | if $dfl_gnu_type ne $gnu_type; | |
100 | } | |
101 | ||
102 | return ($arch, $gnu_type); | |
103 | } | |
104 | ||
105 | use constant { | |
106 | DEB_NONE => 0, | |
107 | DEB_BUILD => 1, | |
108 | DEB_HOST => 2, | |
109 | DEB_TARGET => 64, | |
110 | DEB_ARCH_INFO => 4, | |
111 | DEB_ARCH_ATTR => 8, | |
112 | DEB_MULTIARCH => 16, | |
113 | DEB_GNU_INFO => 32, | |
114 | }; | |
115 | ||
116 | use constant DEB_ALL => DEB_BUILD | DEB_HOST | DEB_TARGET | | |
117 | DEB_ARCH_INFO | DEB_ARCH_ATTR | | |
118 | DEB_MULTIARCH | DEB_GNU_INFO; | |
119 | ||
120 | my %arch_vars = ( | |
121 | DEB_BUILD_ARCH => DEB_BUILD, | |
122 | DEB_BUILD_ARCH_ABI => DEB_BUILD | DEB_ARCH_INFO, | |
123 | DEB_BUILD_ARCH_LIBC => DEB_BUILD | DEB_ARCH_INFO, | |
124 | DEB_BUILD_ARCH_OS => DEB_BUILD | DEB_ARCH_INFO, | |
125 | DEB_BUILD_ARCH_CPU => DEB_BUILD | DEB_ARCH_INFO, | |
126 | DEB_BUILD_ARCH_BITS => DEB_BUILD | DEB_ARCH_ATTR, | |
127 | DEB_BUILD_ARCH_ENDIAN => DEB_BUILD | DEB_ARCH_ATTR, | |
128 | DEB_BUILD_MULTIARCH => DEB_BUILD | DEB_MULTIARCH, | |
129 | DEB_BUILD_GNU_CPU => DEB_BUILD | DEB_GNU_INFO, | |
130 | DEB_BUILD_GNU_SYSTEM => DEB_BUILD | DEB_GNU_INFO, | |
131 | DEB_BUILD_GNU_TYPE => DEB_BUILD | DEB_GNU_INFO, | |
132 | DEB_HOST_ARCH => DEB_HOST, | |
133 | DEB_HOST_ARCH_ABI => DEB_HOST | DEB_ARCH_INFO, | |
134 | DEB_HOST_ARCH_LIBC => DEB_HOST | DEB_ARCH_INFO, | |
135 | DEB_HOST_ARCH_OS => DEB_HOST | DEB_ARCH_INFO, | |
136 | DEB_HOST_ARCH_CPU => DEB_HOST | DEB_ARCH_INFO, | |
137 | DEB_HOST_ARCH_BITS => DEB_HOST | DEB_ARCH_ATTR, | |
138 | DEB_HOST_ARCH_ENDIAN => DEB_HOST | DEB_ARCH_ATTR, | |
139 | DEB_HOST_MULTIARCH => DEB_HOST | DEB_MULTIARCH, | |
140 | DEB_HOST_GNU_CPU => DEB_HOST | DEB_GNU_INFO, | |
141 | DEB_HOST_GNU_SYSTEM => DEB_HOST | DEB_GNU_INFO, | |
142 | DEB_HOST_GNU_TYPE => DEB_HOST | DEB_GNU_INFO, | |
143 | DEB_TARGET_ARCH => DEB_TARGET, | |
144 | DEB_TARGET_ARCH_ABI => DEB_TARGET | DEB_ARCH_INFO, | |
145 | DEB_TARGET_ARCH_LIBC => DEB_TARGET | DEB_ARCH_INFO, | |
146 | DEB_TARGET_ARCH_OS => DEB_TARGET | DEB_ARCH_INFO, | |
147 | DEB_TARGET_ARCH_CPU => DEB_TARGET | DEB_ARCH_INFO, | |
148 | DEB_TARGET_ARCH_BITS => DEB_TARGET | DEB_ARCH_ATTR, | |
149 | DEB_TARGET_ARCH_ENDIAN => DEB_TARGET | DEB_ARCH_ATTR, | |
150 | DEB_TARGET_MULTIARCH => DEB_TARGET | DEB_MULTIARCH, | |
151 | DEB_TARGET_GNU_CPU => DEB_TARGET | DEB_GNU_INFO, | |
152 | DEB_TARGET_GNU_SYSTEM => DEB_TARGET | DEB_GNU_INFO, | |
153 | DEB_TARGET_GNU_TYPE => DEB_TARGET | DEB_GNU_INFO, | |
154 | ); | |
155 | ||
156 | my $req_vars = DEB_ALL; | |
157 | my $req_host_arch = ''; | |
158 | my $req_host_gnu_type = ''; | |
159 | my $req_target_arch = ''; | |
160 | my $req_target_gnu_type = ''; | |
161 | my $req_eq_arch = ''; | |
162 | my $req_is_arch = ''; | |
163 | my $req_match_wildcard = ''; | |
164 | my $req_match_bits = ''; | |
165 | my $req_match_endian = ''; | |
166 | my $req_variable_to_print; | |
167 | my $action = 'list'; | |
168 | my $force = 0; | |
169 | ||
170 | sub action_needs($) { | |
171 | my $bits = shift; | |
172 | return (($req_vars & $bits) == $bits); | |
173 | } | |
174 | ||
175 | @ARGV = normalize_options(args => \@ARGV, delim => '-c'); | |
176 | ||
177 | while (@ARGV) { | |
178 | my $arg = shift; | |
179 | ||
180 | if ($arg eq '-a' or $arg eq '--host-arch') { | |
181 | $req_host_arch = shift; | |
182 | } elsif ($arg eq '-t' or $arg eq '--host-type') { | |
183 | $req_host_gnu_type = shift; | |
184 | } elsif ($arg eq '-A' or $arg eq '--target-arch') { | |
185 | $req_target_arch = shift; | |
186 | } elsif ($arg eq '-T' or $arg eq '--target-type') { | |
187 | $req_target_gnu_type = shift; | |
188 | } elsif ($arg eq '-W' or $arg eq '--match-wildcard') { | |
189 | $req_match_wildcard = shift; | |
190 | } elsif ($arg eq '-B' or $arg eq '--match-bits') { | |
191 | $req_match_bits = shift; | |
192 | } elsif ($arg eq '-E' or $arg eq '--match-endian') { | |
193 | $req_match_endian = shift; | |
194 | } elsif ($arg eq '-e' or $arg eq '--equal') { | |
195 | $req_eq_arch = shift; | |
196 | $req_vars = $arch_vars{DEB_HOST_ARCH}; | |
197 | $action = 'equal'; | |
198 | } elsif ($arg eq '-i' or $arg eq '--is') { | |
199 | $req_is_arch = shift; | |
200 | $req_vars = $arch_vars{DEB_HOST_ARCH}; | |
201 | $action = 'is'; | |
202 | } elsif ($arg eq '-u' or $arg eq '--print-unset') { | |
203 | $req_vars = DEB_NONE; | |
204 | $action = 'print-unset'; | |
205 | } elsif ($arg eq '-l' or $arg eq '--list') { | |
206 | $action = 'list'; | |
207 | } elsif ($arg eq '-s' or $arg eq '--print-set') { | |
208 | $req_vars = DEB_ALL; | |
209 | $action = 'print-set'; | |
210 | } elsif ($arg eq '-f' or $arg eq '--force') { | |
211 | $force=1; | |
212 | } elsif ($arg eq '-q' or $arg eq '--query') { | |
213 | my $varname = shift; | |
214 | error(g_('%s is not a supported variable name'), $varname) | |
215 | unless (exists $arch_vars{$varname}); | |
216 | $req_variable_to_print = "$varname"; | |
217 | $req_vars = $arch_vars{$varname}; | |
218 | $action = 'query'; | |
219 | } elsif ($arg eq '-c' or $arg eq '--command') { | |
220 | $action = 'command'; | |
221 | last; | |
222 | } elsif ($arg eq '-L' or $arg eq '--list-known') { | |
223 | $req_vars = 0; | |
224 | $action = 'list-known'; | |
225 | } elsif ($arg eq '-?' or $arg eq '--help') { | |
226 | usage(); | |
227 | exit 0; | |
228 | } elsif ($arg eq '--version') { | |
229 | version(); | |
230 | exit 0; | |
231 | } else { | |
232 | usageerr(g_("unknown option '%s'"), $arg); | |
233 | } | |
234 | } | |
235 | ||
236 | my %v; | |
237 | ||
238 | # | |
239 | # Set build variables | |
240 | # | |
241 | ||
242 | $v{DEB_BUILD_ARCH} = get_raw_build_arch() | |
243 | if (action_needs(DEB_BUILD)); | |
244 | ($v{DEB_BUILD_ARCH_ABI}, $v{DEB_BUILD_ARCH_LIBC}, | |
245 | $v{DEB_BUILD_ARCH_OS}, $v{DEB_BUILD_ARCH_CPU}) = debarch_to_debtuple($v{DEB_BUILD_ARCH}) | |
246 | if (action_needs(DEB_BUILD | DEB_ARCH_INFO)); | |
247 | ($v{DEB_BUILD_ARCH_BITS}, $v{DEB_BUILD_ARCH_ENDIAN}) = debarch_to_cpuattrs($v{DEB_BUILD_ARCH}) | |
248 | if (action_needs(DEB_BUILD | DEB_ARCH_ATTR)); | |
249 | ||
250 | $v{DEB_BUILD_MULTIARCH} = debarch_to_multiarch($v{DEB_BUILD_ARCH}) | |
251 | if (action_needs(DEB_BUILD | DEB_MULTIARCH)); | |
252 | ||
253 | if (action_needs(DEB_BUILD | DEB_GNU_INFO)) { | |
254 | $v{DEB_BUILD_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_BUILD_ARCH}); | |
255 | ($v{DEB_BUILD_GNU_CPU}, $v{DEB_BUILD_GNU_SYSTEM}) = split(/-/, $v{DEB_BUILD_GNU_TYPE}, 2); | |
256 | } | |
257 | ||
258 | # | |
259 | # Set host variables | |
260 | # | |
261 | ||
262 | # First perform some sanity checks on the host arguments passed. | |
263 | ||
264 | ($req_host_arch, $req_host_gnu_type) = check_arch_coherency($req_host_arch, $req_host_gnu_type); | |
265 | ||
266 | # Proceed to compute the host variables if needed. | |
267 | ||
268 | $v{DEB_HOST_ARCH} = $req_host_arch || get_raw_host_arch() | |
269 | if (action_needs(DEB_HOST)); | |
270 | ($v{DEB_HOST_ARCH_ABI}, $v{DEB_HOST_ARCH_LIBC}, | |
271 | $v{DEB_HOST_ARCH_OS}, $v{DEB_HOST_ARCH_CPU}) = debarch_to_debtuple($v{DEB_HOST_ARCH}) | |
272 | if (action_needs(DEB_HOST | DEB_ARCH_INFO)); | |
273 | ($v{DEB_HOST_ARCH_BITS}, $v{DEB_HOST_ARCH_ENDIAN}) = debarch_to_cpuattrs($v{DEB_HOST_ARCH}) | |
274 | if (action_needs(DEB_HOST | DEB_ARCH_ATTR)); | |
275 | ||
276 | $v{DEB_HOST_MULTIARCH} = debarch_to_multiarch($v{DEB_HOST_ARCH}) | |
277 | if (action_needs(DEB_HOST | DEB_MULTIARCH)); | |
278 | ||
279 | if (action_needs(DEB_HOST | DEB_GNU_INFO)) { | |
280 | if ($req_host_gnu_type eq '') { | |
281 | $v{DEB_HOST_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_HOST_ARCH}); | |
282 | } else { | |
283 | $v{DEB_HOST_GNU_TYPE} = $req_host_gnu_type; | |
284 | } | |
285 | ($v{DEB_HOST_GNU_CPU}, $v{DEB_HOST_GNU_SYSTEM}) = split(/-/, $v{DEB_HOST_GNU_TYPE}, 2); | |
286 | ||
287 | my $host_gnu_type = get_host_gnu_type(); | |
288 | ||
289 | warning(g_('specified GNU system type %s does not match CC system ' . | |
290 | 'type %s, try setting a correct CC environment variable'), | |
291 | $v{DEB_HOST_GNU_TYPE}, $host_gnu_type) | |
292 | if ($host_gnu_type ne '') && ($host_gnu_type ne $v{DEB_HOST_GNU_TYPE}); | |
293 | } | |
294 | ||
295 | # | |
296 | # Set target variables | |
297 | # | |
298 | ||
299 | # First perform some sanity checks on the target arguments passed. | |
300 | ||
301 | ($req_target_arch, $req_target_gnu_type) = check_arch_coherency($req_target_arch, $req_target_gnu_type); | |
302 | ||
303 | # Proceed to compute the target variables if needed. | |
304 | ||
305 | $v{DEB_TARGET_ARCH} = $req_target_arch || $req_host_arch || get_raw_host_arch() | |
306 | if (action_needs(DEB_TARGET)); | |
307 | ($v{DEB_TARGET_ARCH_ABI}, $v{DEB_TARGET_ARCH_LIBC}, | |
308 | $v{DEB_TARGET_ARCH_OS}, $v{DEB_TARGET_ARCH_CPU}) = debarch_to_debtuple($v{DEB_TARGET_ARCH}) | |
309 | if (action_needs(DEB_TARGET | DEB_ARCH_INFO)); | |
310 | ($v{DEB_TARGET_ARCH_BITS}, $v{DEB_TARGET_ARCH_ENDIAN}) = debarch_to_cpuattrs($v{DEB_TARGET_ARCH}) | |
311 | if (action_needs(DEB_TARGET | DEB_ARCH_ATTR)); | |
312 | ||
313 | $v{DEB_TARGET_MULTIARCH} = debarch_to_multiarch($v{DEB_TARGET_ARCH}) | |
314 | if (action_needs(DEB_TARGET | DEB_MULTIARCH)); | |
315 | ||
316 | if (action_needs(DEB_TARGET | DEB_GNU_INFO)) { | |
317 | if ($req_target_gnu_type eq '') { | |
318 | $v{DEB_TARGET_GNU_TYPE} = debarch_to_gnutriplet($v{DEB_TARGET_ARCH}); | |
319 | } else { | |
320 | $v{DEB_TARGET_GNU_TYPE} = $req_target_gnu_type; | |
321 | } | |
322 | ($v{DEB_TARGET_GNU_CPU}, $v{DEB_TARGET_GNU_SYSTEM}) = split(/-/, $v{DEB_TARGET_GNU_TYPE}, 2); | |
323 | } | |
324 | ||
325 | ||
326 | for my $k (keys %arch_vars) { | |
327 | $v{$k} = $ENV{$k} if (length $ENV{$k} && !$force); | |
328 | } | |
329 | ||
330 | if ($action eq 'list') { | |
331 | foreach my $k (sort keys %arch_vars) { | |
332 | print "$k=$v{$k}\n"; | |
333 | } | |
334 | } elsif ($action eq 'print-set') { | |
335 | foreach my $k (sort keys %arch_vars) { | |
336 | print "$k=$v{$k}; "; | |
337 | } | |
338 | print 'export ' . join(' ', sort keys %arch_vars) . "\n"; | |
339 | } elsif ($action eq 'print-unset') { | |
340 | print 'unset ' . join(' ', sort keys %arch_vars) . "\n"; | |
341 | } elsif ($action eq 'equal') { | |
342 | exit !debarch_eq($v{DEB_HOST_ARCH}, $req_eq_arch); | |
343 | } elsif ($action eq 'is') { | |
344 | exit !debarch_is($v{DEB_HOST_ARCH}, $req_is_arch); | |
345 | } elsif ($action eq 'command') { | |
346 | @ENV{keys %v} = values %v; | |
347 | exec @ARGV; | |
348 | } elsif ($action eq 'query') { | |
349 | print "$v{$req_variable_to_print}\n"; | |
350 | } elsif ($action eq 'list-known') { | |
351 | foreach my $arch (get_valid_arches()) { | |
352 | my ($bits, $endian) = debarch_to_cpuattrs($arch); | |
353 | ||
354 | next if $req_match_endian and $endian ne $req_match_endian; | |
355 | next if $req_match_bits and $bits ne $req_match_bits; | |
356 | next if $req_match_wildcard and not debarch_is($arch, $req_match_wildcard); | |
357 | ||
358 | print "$arch\n"; | |
359 | } | |
360 | } |