File: | Dpkg/BuildFlags.pm |
Coverage: | 73.5% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | # Copyright © 2010-2011 Raphaël Hertzog <hertzog@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::BuildFlags; | ||||||
17 | |||||||
18 | 3 3 3 | 7 2 34 | use strict; | ||||
19 | 3 3 3 | 4 2 66 | use warnings; | ||||
20 | |||||||
21 | our $VERSION = '1.04'; | ||||||
22 | |||||||
23 | 3 3 3 | 242 4 27 | use Dpkg (); | ||||
24 | 3 3 3 | 225 2 69 | use Dpkg::Gettext; | ||||
25 | 3 3 3 | 231 2 33 | use Dpkg::Build::Env; | ||||
26 | 3 3 3 | 224 3 97 | use Dpkg::ErrorHandling; | ||||
27 | 3 3 3 | 370 2 2260 | use Dpkg::Vendor qw(run_vendor_hook); | ||||
28 | |||||||
29 | =encoding utf8 | ||||||
30 | |||||||
31 - 49 | =head1 NAME Dpkg::BuildFlags - query build flags =head1 DESCRIPTION This class is used by dpkg-buildflags and can be used to query the same information. =head1 METHODS =over 4 =item $bf = Dpkg::BuildFlags->new() Create a new Dpkg::BuildFlags object. It will be initialized based on the value of several configuration files and environment variables. =cut | ||||||
50 | |||||||
51 | sub new { | ||||||
52 | 4 | 1 | 5 | my ($this, %opts) = @_; | |||
53 | 4 | 13 | my $class = ref($this) || $this; | ||||
54 | |||||||
55 | 4 | 4 | my $self = { | ||||
56 | }; | ||||||
57 | 4 | 5 | bless $self, $class; | ||||
58 | 4 | 6 | $self->load_vendor_defaults(); | ||||
59 | 4 | 11 | return $self; | ||||
60 | } | ||||||
61 | |||||||
62 - 66 | =item $bf->load_vendor_defaults() Reset the flags stored to the default set provided by the vendor. =cut | ||||||
67 | |||||||
68 | sub load_vendor_defaults { | ||||||
69 | 4 | 1 | 3 | my $self = shift; | |||
70 | |||||||
71 | 4 | 8 | $self->{features} = {}; | ||||
72 | $self->{flags} = { | ||||||
73 | 4 | 15 | ASFLAGS => '', | ||||
74 | CPPFLAGS => '', | ||||||
75 | CFLAGS => '', | ||||||
76 | CXXFLAGS => '', | ||||||
77 | OBJCFLAGS => '', | ||||||
78 | OBJCXXFLAGS => '', | ||||||
79 | GCJFLAGS => '', | ||||||
80 | DFLAGS => '', | ||||||
81 | FFLAGS => '', | ||||||
82 | FCFLAGS => '', | ||||||
83 | LDFLAGS => '', | ||||||
84 | }; | ||||||
85 | $self->{origin} = { | ||||||
86 | 4 | 14 | ASFLAGS => 'vendor', | ||||
87 | CPPFLAGS => 'vendor', | ||||||
88 | CFLAGS => 'vendor', | ||||||
89 | CXXFLAGS => 'vendor', | ||||||
90 | OBJCFLAGS => 'vendor', | ||||||
91 | OBJCXXFLAGS => 'vendor', | ||||||
92 | GCJFLAGS => 'vendor', | ||||||
93 | DFLAGS => 'vendor', | ||||||
94 | FFLAGS => 'vendor', | ||||||
95 | FCFLAGS => 'vendor', | ||||||
96 | LDFLAGS => 'vendor', | ||||||
97 | }; | ||||||
98 | $self->{maintainer} = { | ||||||
99 | 4 | 11 | ASFLAGS => 0, | ||||
100 | CPPFLAGS => 0, | ||||||
101 | CFLAGS => 0, | ||||||
102 | CXXFLAGS => 0, | ||||||
103 | OBJCFLAGS => 0, | ||||||
104 | OBJCXXFLAGS => 0, | ||||||
105 | GCJFLAGS => 0, | ||||||
106 | DFLAGS => 0, | ||||||
107 | FFLAGS => 0, | ||||||
108 | FCFLAGS => 0, | ||||||
109 | LDFLAGS => 0, | ||||||
110 | }; | ||||||
111 | # The vendor hook will add the feature areas build flags. | ||||||
112 | 4 | 4 | run_vendor_hook('update-buildflags', $self); | ||||
113 | } | ||||||
114 | |||||||
115 - 119 | =item $bf->load_system_config() Update flags from the system configuration. =cut | ||||||
120 | |||||||
121 | sub load_system_config { | ||||||
122 | 1 | 1 | 0 | my $self = shift; | |||
123 | |||||||
124 | 1 | 3 | $self->update_from_conffile("$Dpkg::CONFDIR/buildflags.conf", 'system'); | ||||
125 | } | ||||||
126 | |||||||
127 - 131 | =item $bf->load_user_config() Update flags from the user configuration. =cut | ||||||
132 | |||||||
133 | sub load_user_config { | ||||||
134 | 1 | 1 | 22 | my $self = shift; | |||
135 | |||||||
136 | 1 | 2 | my $confdir = $ENV{XDG_CONFIG_HOME}; | ||||
137 | 1 | 3 | $confdir ||= $ENV{HOME} . '/.config' if length $ENV{HOME}; | ||||
138 | 1 | 1 | if (length $confdir) { | ||||
139 | 1 | 21 | $self->update_from_conffile("$confdir/dpkg/buildflags.conf", 'user'); | ||||
140 | } | ||||||
141 | } | ||||||
142 | |||||||
143 - 148 | =item $bf->load_environment_config() Update flags based on user directives stored in the environment. See dpkg-buildflags(1) for details. =cut | ||||||
149 | |||||||
150 | sub load_environment_config { | ||||||
151 | 1 | 1 | 1 | my $self = shift; | |||
152 | |||||||
153 | 1 1 | 1 1 | foreach my $flag (keys %{$self->{flags}}) { | ||||
154 | 11 | 6 | my $envvar = 'DEB_' . $flag . '_SET'; | ||||
155 | 11 | 7 | if (Dpkg::Build::Env::has($envvar)) { | ||||
156 | 0 | 0 | $self->set($flag, Dpkg::Build::Env::get($envvar), 'env'); | ||||
157 | } | ||||||
158 | 11 | 6 | $envvar = 'DEB_' . $flag . '_STRIP'; | ||||
159 | 11 | 6 | if (Dpkg::Build::Env::has($envvar)) { | ||||
160 | 0 | 0 | $self->strip($flag, Dpkg::Build::Env::get($envvar), 'env'); | ||||
161 | } | ||||||
162 | 11 | 4 | $envvar = 'DEB_' . $flag . '_APPEND'; | ||||
163 | 11 | 8 | if (Dpkg::Build::Env::has($envvar)) { | ||||
164 | 0 | 0 | $self->append($flag, Dpkg::Build::Env::get($envvar), 'env'); | ||||
165 | } | ||||||
166 | 11 | 7 | $envvar = 'DEB_' . $flag . '_PREPEND'; | ||||
167 | 11 | 7 | if (Dpkg::Build::Env::has($envvar)) { | ||||
168 | 0 | 0 | $self->prepend($flag, Dpkg::Build::Env::get($envvar), 'env'); | ||||
169 | } | ||||||
170 | } | ||||||
171 | } | ||||||
172 | |||||||
173 - 178 | =item $bf->load_maintainer_config() Update flags based on maintainer directives stored in the environment. See dpkg-buildflags(1) for details. =cut | ||||||
179 | |||||||
180 | sub load_maintainer_config { | ||||||
181 | 1 | 1 | 1 | my $self = shift; | |||
182 | |||||||
183 | 1 1 | 0 2 | foreach my $flag (keys %{$self->{flags}}) { | ||||
184 | 11 | 7 | my $envvar = 'DEB_' . $flag . '_MAINT_SET'; | ||||
185 | 11 | 5 | if (Dpkg::Build::Env::has($envvar)) { | ||||
186 | 0 | 0 | $self->set($flag, Dpkg::Build::Env::get($envvar), undef, 1); | ||||
187 | } | ||||||
188 | 11 | 4 | $envvar = 'DEB_' . $flag . '_MAINT_STRIP'; | ||||
189 | 11 | 8 | if (Dpkg::Build::Env::has($envvar)) { | ||||
190 | 0 | 0 | $self->strip($flag, Dpkg::Build::Env::get($envvar), undef, 1); | ||||
191 | } | ||||||
192 | 11 | 5 | $envvar = 'DEB_' . $flag . '_MAINT_APPEND'; | ||||
193 | 11 | 7 | if (Dpkg::Build::Env::has($envvar)) { | ||||
194 | 0 | 0 | $self->append($flag, Dpkg::Build::Env::get($envvar), undef, 1); | ||||
195 | } | ||||||
196 | 11 | 6 | $envvar = 'DEB_' . $flag . '_MAINT_PREPEND'; | ||||
197 | 11 | 5 | if (Dpkg::Build::Env::has($envvar)) { | ||||
198 | 0 | 0 | $self->prepend($flag, Dpkg::Build::Env::get($envvar), undef, 1); | ||||
199 | } | ||||||
200 | } | ||||||
201 | } | ||||||
202 | |||||||
203 | |||||||
204 - 210 | =item $bf->load_config() Call successively load_system_config(), load_user_config(), load_environment_config() and load_maintainer_config() to update the default build flags defined by the vendor. =cut | ||||||
211 | |||||||
212 | sub load_config { | ||||||
213 | 1 | 1 | 1 | my $self = shift; | |||
214 | |||||||
215 | 1 | 2 | $self->load_system_config(); | ||||
216 | 1 | 1 | $self->load_user_config(); | ||||
217 | 1 | 1 | $self->load_environment_config(); | ||||
218 | 1 | 1 | $self->load_maintainer_config(); | ||||
219 | } | ||||||
220 | |||||||
221 - 225 | =item $bf->unset($flag) Unset the build flag $flag, so that it will not be known anymore. =cut | ||||||
226 | |||||||
227 | sub unset { | ||||||
228 | 0 | 1 | 0 | my ($self, $flag) = @_; | |||
229 | |||||||
230 | 0 | 0 | delete $self->{flags}->{$flag}; | ||||
231 | 0 | 0 | delete $self->{origin}->{$flag}; | ||||
232 | 0 | 0 | delete $self->{maintainer}->{$flag}; | ||||
233 | } | ||||||
234 | |||||||
235 - 241 | =item $bf->set($flag, $value, $source, $maint) Update the build flag $flag with value $value and record its origin as $source (if defined). Record it as maintainer modified if $maint is defined and true. =cut | ||||||
242 | |||||||
243 | sub set { | ||||||
244 | 8 | 1 | 3 | my ($self, $flag, $value, $src, $maint) = @_; | |||
245 | 8 | 8 | $self->{flags}->{$flag} = $value; | ||||
246 | 8 | 8 | $self->{origin}->{$flag} = $src if defined $src; | ||||
247 | 8 | 5 | $self->{maintainer}->{$flag} = $maint if $maint; | ||||
248 | } | ||||||
249 | |||||||
250 - 256 | =item $bf->set_feature($area, $feature, $enabled) Update the boolean state of whether a specific feature within a known feature area has been enabled. The only currently known feature areas are "future", "qa", "sanitize", "optimize", "hardening" and "reproducible". =cut | ||||||
257 | |||||||
258 | sub set_feature { | ||||||
259 | 72 | 1 | 43 | my ($self, $area, $feature, $enabled) = @_; | |||
260 | 72 | 62 | $self->{features}{$area}{$feature} = $enabled; | ||||
261 | } | ||||||
262 | |||||||
263 - 269 | =item $bf->strip($flag, $value, $source, $maint) Update the build flag $flag by stripping the flags listed in $value and record its origin as $source (if defined). Record it as maintainer modified if $maint is defined and true. =cut | ||||||
270 | |||||||
271 | sub strip { | ||||||
272 | 1 | 1 | 26 | my ($self, $flag, $value, $src, $maint) = @_; | |||
273 | 1 | 2 | foreach my $tostrip (split(/\s+/, $value)) { | ||||
274 | 1 | 2 | next unless length $tostrip; | ||||
275 | 1 | 26 | $self->{flags}->{$flag} =~ s/(^|\s+)\Q$tostrip\E(\s+|$)/ /g; | ||||
276 | } | ||||||
277 | 1 | 1 | $self->{flags}->{$flag} =~ s/^\s+//g; | ||||
278 | 1 | 2 | $self->{flags}->{$flag} =~ s/\s+$//g; | ||||
279 | 1 | 2 | $self->{origin}->{$flag} = $src if defined $src; | ||||
280 | 1 | 1 | $self->{maintainer}->{$flag} = $maint if $maint; | ||||
281 | } | ||||||
282 | |||||||
283 - 289 | =item $bf->append($flag, $value, $source, $maint) Append the options listed in $value to the current value of the flag $flag. Record its origin as $source (if defined). Record it as maintainer modified if $maint is defined and true. =cut | ||||||
290 | |||||||
291 | sub append { | ||||||
292 | 117 | 1 | 68 | my ($self, $flag, $value, $src, $maint) = @_; | |||
293 | 117 | 81 | if (length($self->{flags}->{$flag})) { | ||||
294 | 77 | 57 | $self->{flags}->{$flag} .= " $value"; | ||||
295 | } else { | ||||||
296 | 40 | 31 | $self->{flags}->{$flag} = $value; | ||||
297 | } | ||||||
298 | 117 | 65 | $self->{origin}->{$flag} = $src if defined $src; | ||||
299 | 117 | 109 | $self->{maintainer}->{$flag} = $maint if $maint; | ||||
300 | } | ||||||
301 | |||||||
302 - 308 | =item $bf->prepend($flag, $value, $source, $maint) Prepend the options listed in $value to the current value of the flag $flag. Record its origin as $source (if defined). Record it as maintainer modified if $maint is defined and true. =cut | ||||||
309 | |||||||
310 | sub prepend { | ||||||
311 | 3 | 1 | 3 | my ($self, $flag, $value, $src, $maint) = @_; | |||
312 | 3 | 4 | if (length($self->{flags}->{$flag})) { | ||||
313 | 3 | 6 | $self->{flags}->{$flag} = "$value " . $self->{flags}->{$flag}; | ||||
314 | } else { | ||||||
315 | 0 | 0 | $self->{flags}->{$flag} = $value; | ||||
316 | } | ||||||
317 | 3 | 2 | $self->{origin}->{$flag} = $src if defined $src; | ||||
318 | 3 | 6 | $self->{maintainer}->{$flag} = $maint if $maint; | ||||
319 | } | ||||||
320 | |||||||
321 | |||||||
322 - 329 | =item $bf->update_from_conffile($file, $source) Update the current build flags based on the configuration directives contained in $file. See dpkg-buildflags(1) for the format of the directives. $source is the origin recorded for any build flag set or modified. =cut | ||||||
330 | |||||||
331 | sub update_from_conffile { | ||||||
332 | 2 | 1 | 2 | my ($self, $file, $src) = @_; | |||
333 | 2 | 2 | local $_; | ||||
334 | |||||||
335 | 2 | 10 | return unless -e $file; | ||||
336 | 0 | 0 | open(my $conf_fh, '<', $file) or syserr(g_('cannot read %s'), $file); | ||||
337 | 0 | 0 | while (<$conf_fh>) { | ||||
338 | 0 | 0 | chomp; | ||||
339 | 0 | 0 | next if /^\s*#/; # Skip comments | ||||
340 | 0 | 0 | next if /^\s*$/; # Skip empty lines | ||||
341 | 0 | 0 | if (/^(append|prepend|set|strip)\s+(\S+)\s+(\S.*\S)\s*$/i) { | ||||
342 | 0 | 0 | my ($op, $flag, $value) = ($1, $2, $3); | ||||
343 | 0 | 0 | unless (exists $self->{flags}->{$flag}) { | ||||
344 | 0 | 0 | warning(g_('line %d of %s mentions unknown flag %s'), $., $file, $flag); | ||||
345 | 0 | 0 | $self->{flags}->{$flag} = ''; | ||||
346 | } | ||||||
347 | 0 | 0 | if (lc($op) eq 'set') { | ||||
348 | 0 | 0 | $self->set($flag, $value, $src); | ||||
349 | } elsif (lc($op) eq 'strip') { | ||||||
350 | 0 | 0 | $self->strip($flag, $value, $src); | ||||
351 | } elsif (lc($op) eq 'append') { | ||||||
352 | 0 | 0 | $self->append($flag, $value, $src); | ||||
353 | } elsif (lc($op) eq 'prepend') { | ||||||
354 | 0 | 0 | $self->prepend($flag, $value, $src); | ||||
355 | } | ||||||
356 | } else { | ||||||
357 | 0 | 0 | warning(g_('line %d of %s is invalid, it has been ignored'), $., $file); | ||||
358 | } | ||||||
359 | } | ||||||
360 | 0 | 0 | close($conf_fh); | ||||
361 | } | ||||||
362 | |||||||
363 - 368 | =item $bf->get($flag) Return the value associated to the flag. It might be undef if the flag doesn't exist. =cut | ||||||
369 | |||||||
370 | sub get { | ||||||
371 | 37 | 1 | 26 | my ($self, $key) = @_; | |||
372 | 37 | 32 | return $self->{flags}{$key}; | ||||
373 | } | ||||||
374 | |||||||
375 - 380 | =item $bf->get_feature_areas() Return the feature areas (i.e. the area values has_features will return true for). =cut | ||||||
381 | |||||||
382 | sub get_feature_areas { | ||||||
383 | 1 | 1 | 0 | my $self = shift; | |||
384 | |||||||
385 | 1 1 | 1 5 | return keys %{$self->{features}}; | ||||
386 | } | ||||||
387 | |||||||
388 - 393 | =item $bf->get_features($area) Return, for the given area, a hash with keys as feature names, and values as booleans indicating whether the feature is enabled or not. =cut | ||||||
394 | |||||||
395 | sub get_features { | ||||||
396 | 6 | 1 | 6 | my ($self, $area) = @_; | |||
397 | 6 6 | 3 12 | return %{$self->{features}{$area}}; | ||||
398 | } | ||||||
399 | |||||||
400 - 405 | =item $bf->get_origin($flag) Return the origin associated to the flag. It might be undef if the flag doesn't exist. =cut | ||||||
406 | |||||||
407 | sub get_origin { | ||||||
408 | 5 | 1 | 5 | my ($self, $key) = @_; | |||
409 | 5 | 7 | return $self->{origin}{$key}; | ||||
410 | } | ||||||
411 | |||||||
412 - 416 | =item $bf->is_maintainer_modified($flag) Return true if the flag is modified by the maintainer. =cut | ||||||
417 | |||||||
418 | sub is_maintainer_modified { | ||||||
419 | 4 | 1 | 3 | my ($self, $key) = @_; | |||
420 | 4 | 6 | return $self->{maintainer}{$key}; | ||||
421 | } | ||||||
422 | |||||||
423 - 429 | =item $bf->has_features($area) Returns true if the given area of features is known, and false otherwise. The only currently recognized feature areas are "future", "qa", "sanitize", "hardening" and "reproducible". =cut | ||||||
430 | |||||||
431 | sub has_features { | ||||||
432 | 6 | 1 | 5 | my ($self, $area) = @_; | |||
433 | 6 | 9 | return exists $self->{features}{$area}; | ||||
434 | } | ||||||
435 | |||||||
436 - 440 | =item $bf->has($option) Returns a boolean indicating whether the flags exists in the object. =cut | ||||||
441 | |||||||
442 | sub has { | ||||||
443 | 1 | 1 | 1 | my ($self, $key) = @_; | |||
444 | 1 | 2 | return exists $self->{flags}{$key}; | ||||
445 | } | ||||||
446 | |||||||
447 - 451 | =item @flags = $bf->list() Returns the list of flags stored in the object. =cut | ||||||
452 | |||||||
453 | sub list { | ||||||
454 | 1 | 1 | 1 | my $self = shift; | |||
455 | 1 1 | 0 3 | my @list = sort keys %{$self->{flags}}; | ||||
456 | 1 | 3 | return @list; | ||||
457 | } | ||||||
458 | |||||||
459 | =back | ||||||
460 | |||||||
461 - 491 | =head1 CHANGES =head2 Version 1.04 (dpkg 1.20.0) New method: $bf->unset(). =head2 Version 1.03 (dpkg 1.16.5) New method: $bf->get_feature_areas() to list possible values for $bf->get_features. New method $bf->is_maintainer_modified() and new optional parameter to $bf->set(), $bf->append(), $bf->prepend(), $bf->strip(). =head2 Version 1.02 (dpkg 1.16.2) New methods: $bf->get_features(), $bf->has_features(), $bf->set_feature(). =head2 Version 1.01 (dpkg 1.16.1) New method: $bf->prepend() very similar to append(). Implement support of the prepend operation everywhere. New method: $bf->load_maintainer_config() that update the build flags based on the package maintainer directives. =head2 Version 1.00 (dpkg 1.15.7) Mark the module as public. =cut | ||||||
492 | |||||||
493 | 1; |