OLD | NEW |
| (Empty) |
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 use strict; | |
19 use warnings; | |
20 | |
21 our $VERSION = '1.03'; | |
22 | |
23 use Dpkg (); | |
24 use Dpkg::Gettext; | |
25 use Dpkg::BuildEnv; | |
26 use Dpkg::BuildOptions; | |
27 use Dpkg::ErrorHandling; | |
28 use Dpkg::Vendor qw(run_vendor_hook); | |
29 | |
30 =encoding utf8 | |
31 | |
32 =head1 NAME | |
33 | |
34 Dpkg::BuildFlags - query build flags | |
35 | |
36 =head1 DESCRIPTION | |
37 | |
38 The Dpkg::BuildFlags object is used by dpkg-buildflags and can be used | |
39 to query the same information. | |
40 | |
41 =head1 FUNCTIONS | |
42 | |
43 =over 4 | |
44 | |
45 =item my $bf = Dpkg::BuildFlags->new() | |
46 | |
47 Create a new Dpkg::BuildFlags object. It will be initialized based | |
48 on the value of several configuration files and environment variables. | |
49 | |
50 =cut | |
51 | |
52 sub new { | |
53 my ($this, %opts) = @_; | |
54 my $class = ref($this) || $this; | |
55 | |
56 my $self = { | |
57 }; | |
58 bless $self, $class; | |
59 $self->load_vendor_defaults(); | |
60 return $self; | |
61 } | |
62 | |
63 =item $bf->load_vendor_defaults() | |
64 | |
65 Reset the flags stored to the default set provided by the vendor. | |
66 | |
67 =cut | |
68 | |
69 sub load_vendor_defaults { | |
70 my ($self) = @_; | |
71 $self->{options} = {}; | |
72 $self->{source} = {}; | |
73 $self->{features} = {}; | |
74 my $build_opts = Dpkg::BuildOptions->new(); | |
75 $self->{build_options} = $build_opts; | |
76 my $default_flags = $build_opts->has('noopt') ? '-g -O0' : '-g -O2'; | |
77 $self->{flags} = { | |
78 CPPFLAGS => '', | |
79 CFLAGS => $default_flags, | |
80 CXXFLAGS => $default_flags, | |
81 GCJFLAGS => $default_flags, | |
82 FFLAGS => $default_flags, | |
83 LDFLAGS => '', | |
84 }; | |
85 $self->{origin} = { | |
86 CPPFLAGS => 'vendor', | |
87 CFLAGS => 'vendor', | |
88 CXXFLAGS => 'vendor', | |
89 GCJFLAGS => 'vendor', | |
90 FFLAGS => 'vendor', | |
91 LDFLAGS => 'vendor', | |
92 }; | |
93 $self->{maintainer} = { | |
94 CPPFLAGS => 0, | |
95 CFLAGS => 0, | |
96 CXXFLAGS => 0, | |
97 GCJFLAGS => 0, | |
98 FFLAGS => 0, | |
99 LDFLAGS => 0, | |
100 }; | |
101 # The Debian vendor hook will add hardening build flags | |
102 run_vendor_hook('update-buildflags', $self); | |
103 } | |
104 | |
105 =item $bf->load_system_config() | |
106 | |
107 Update flags from the system configuration. | |
108 | |
109 =cut | |
110 | |
111 sub load_system_config { | |
112 my ($self) = @_; | |
113 $self->update_from_conffile("$Dpkg::CONFDIR/buildflags.conf", 'system'); | |
114 } | |
115 | |
116 =item $bf->load_user_config() | |
117 | |
118 Update flags from the user configuration. | |
119 | |
120 =cut | |
121 | |
122 sub load_user_config { | |
123 my ($self) = @_; | |
124 my $confdir = $ENV{XDG_CONFIG_HOME}; | |
125 $confdir ||= $ENV{HOME} . '/.config' if defined $ENV{HOME}; | |
126 if (defined $confdir) { | |
127 $self->update_from_conffile("$confdir/dpkg/buildflags.conf", 'user'); | |
128 } | |
129 } | |
130 | |
131 =item $bf->load_environment_config() | |
132 | |
133 Update flags based on user directives stored in the environment. See | |
134 dpkg-buildflags(1) for details. | |
135 | |
136 =cut | |
137 | |
138 sub load_environment_config { | |
139 my ($self) = @_; | |
140 foreach my $flag (keys %{$self->{flags}}) { | |
141 my $envvar = 'DEB_' . $flag . '_SET'; | |
142 if (Dpkg::BuildEnv::has($envvar)) { | |
143 $self->set($flag, Dpkg::BuildEnv::get($envvar), 'env'); | |
144 } | |
145 $envvar = 'DEB_' . $flag . '_STRIP'; | |
146 if (Dpkg::BuildEnv::has($envvar)) { | |
147 $self->strip($flag, Dpkg::BuildEnv::get($envvar), 'env'); | |
148 } | |
149 $envvar = 'DEB_' . $flag . '_APPEND'; | |
150 if (Dpkg::BuildEnv::has($envvar)) { | |
151 $self->append($flag, Dpkg::BuildEnv::get($envvar), 'env'); | |
152 } | |
153 $envvar = 'DEB_' . $flag . '_PREPEND'; | |
154 if (Dpkg::BuildEnv::has($envvar)) { | |
155 $self->prepend($flag, Dpkg::BuildEnv::get($envvar), 'env'); | |
156 } | |
157 } | |
158 } | |
159 | |
160 =item $bf->load_maintainer_config() | |
161 | |
162 Update flags based on maintainer directives stored in the environment. See | |
163 dpkg-buildflags(1) for details. | |
164 | |
165 =cut | |
166 | |
167 sub load_maintainer_config { | |
168 my ($self) = @_; | |
169 foreach my $flag (keys %{$self->{flags}}) { | |
170 my $envvar = 'DEB_' . $flag . '_MAINT_SET'; | |
171 if (Dpkg::BuildEnv::has($envvar)) { | |
172 $self->set($flag, Dpkg::BuildEnv::get($envvar), undef, 1); | |
173 } | |
174 $envvar = 'DEB_' . $flag . '_MAINT_STRIP'; | |
175 if (Dpkg::BuildEnv::has($envvar)) { | |
176 $self->strip($flag, Dpkg::BuildEnv::get($envvar), undef, 1); | |
177 } | |
178 $envvar = 'DEB_' . $flag . '_MAINT_APPEND'; | |
179 if (Dpkg::BuildEnv::has($envvar)) { | |
180 $self->append($flag, Dpkg::BuildEnv::get($envvar), undef, 1); | |
181 } | |
182 $envvar = 'DEB_' . $flag . '_MAINT_PREPEND'; | |
183 if (Dpkg::BuildEnv::has($envvar)) { | |
184 $self->prepend($flag, Dpkg::BuildEnv::get($envvar), undef, 1); | |
185 } | |
186 } | |
187 } | |
188 | |
189 | |
190 =item $bf->load_config() | |
191 | |
192 Call successively load_system_config(), load_user_config(), | |
193 load_environment_config() and load_maintainer_config() to update the | |
194 default build flags defined by the vendor. | |
195 | |
196 =cut | |
197 | |
198 sub load_config { | |
199 my ($self) = @_; | |
200 $self->load_system_config(); | |
201 $self->load_user_config(); | |
202 $self->load_environment_config(); | |
203 $self->load_maintainer_config(); | |
204 } | |
205 | |
206 =item $bf->set($flag, $value, $source, $maint) | |
207 | |
208 Update the build flag $flag with value $value and record its origin as | |
209 $source (if defined). Record it as maintainer modified if $maint is | |
210 defined and true. | |
211 | |
212 =cut | |
213 | |
214 sub set { | |
215 my ($self, $flag, $value, $src, $maint) = @_; | |
216 $self->{flags}->{$flag} = $value; | |
217 $self->{origin}->{$flag} = $src if defined $src; | |
218 $self->{maintainer}->{$flag} = $maint if $maint; | |
219 } | |
220 | |
221 =item $bf->set_feature($area, $feature, $enabled) | |
222 | |
223 Update the boolean state of whether a specific feature within a known | |
224 feature area has been enabled. The only currently known feature area is | |
225 "hardening". | |
226 | |
227 =cut | |
228 | |
229 sub set_feature { | |
230 my ($self, $area, $feature, $enabled) = @_; | |
231 $self->{features}{$area}{$feature} = $enabled; | |
232 } | |
233 | |
234 =item $bf->strip($flag, $value, $source, $maint) | |
235 | |
236 Update the build flag $flag by stripping the flags listed in $value and | |
237 record its origin as $source (if defined). Record it as maintainer modified | |
238 if $maint is defined and true. | |
239 | |
240 =cut | |
241 | |
242 sub strip { | |
243 my ($self, $flag, $value, $src, $maint) = @_; | |
244 foreach my $tostrip (split(/\s+/, $value)) { | |
245 next unless length $tostrip; | |
246 $self->{flags}->{$flag} =~ s/(^|\s+)\Q$tostrip\E(\s+|$)/ /g; | |
247 } | |
248 $self->{flags}->{$flag} =~ s/^\s+//g; | |
249 $self->{flags}->{$flag} =~ s/\s+$//g; | |
250 $self->{origin}->{$flag} = $src if defined $src; | |
251 $self->{maintainer}->{$flag} = $maint if $maint; | |
252 } | |
253 | |
254 =item $bf->append($flag, $value, $source, $maint) | |
255 | |
256 Append the options listed in $value to the current value of the flag $flag. | |
257 Record its origin as $source (if defined). Record it as maintainer modified | |
258 if $maint is defined and true. | |
259 | |
260 =cut | |
261 | |
262 sub append { | |
263 my ($self, $flag, $value, $src, $maint) = @_; | |
264 if (length($self->{flags}->{$flag})) { | |
265 $self->{flags}->{$flag} .= " $value"; | |
266 } else { | |
267 $self->{flags}->{$flag} = $value; | |
268 } | |
269 $self->{origin}->{$flag} = $src if defined $src; | |
270 $self->{maintainer}->{$flag} = $maint if $maint; | |
271 } | |
272 | |
273 =item $bf->prepend($flag, $value, $source, $maint) | |
274 | |
275 Prepend the options listed in $value to the current value of the flag $flag. | |
276 Record its origin as $source (if defined). Record it as maintainer modified | |
277 if $maint is defined and true. | |
278 | |
279 =cut | |
280 | |
281 sub prepend { | |
282 my ($self, $flag, $value, $src, $maint) = @_; | |
283 if (length($self->{flags}->{$flag})) { | |
284 $self->{flags}->{$flag} = "$value " . $self->{flags}->{$flag}; | |
285 } else { | |
286 $self->{flags}->{$flag} = $value; | |
287 } | |
288 $self->{origin}->{$flag} = $src if defined $src; | |
289 $self->{maintainer}->{$flag} = $maint if $maint; | |
290 } | |
291 | |
292 | |
293 =item $bf->update_from_conffile($file, $source) | |
294 | |
295 Update the current build flags based on the configuration directives | |
296 contained in $file. See dpkg-buildflags(1) for the format of the directives. | |
297 | |
298 $source is the origin recorded for any build flag set or modified. | |
299 | |
300 =cut | |
301 | |
302 sub update_from_conffile { | |
303 my ($self, $file, $src) = @_; | |
304 return unless -e $file; | |
305 open(my $conf_fh, '<', $file) or syserr(_g('cannot read %s'), $file); | |
306 while (<$conf_fh>) { | |
307 chomp; | |
308 next if /^\s*#/; # Skip comments | |
309 next if /^\s*$/; # Skip empty lines | |
310 if (/^(append|prepend|set|strip)\s+(\S+)\s+(\S.*\S)\s*$/i) { | |
311 my ($op, $flag, $value) = ($1, $2, $3); | |
312 unless (exists $self->{flags}->{$flag}) { | |
313 warning(_g('line %d of %s mentions unknown flag %s'), $., $file,
$flag); | |
314 $self->{flags}->{$flag} = ''; | |
315 } | |
316 if (lc($op) eq 'set') { | |
317 $self->set($flag, $value, $src); | |
318 } elsif (lc($op) eq 'strip') { | |
319 $self->strip($flag, $value, $src); | |
320 } elsif (lc($op) eq 'append') { | |
321 $self->append($flag, $value, $src); | |
322 } elsif (lc($op) eq 'prepend') { | |
323 $self->prepend($flag, $value, $src); | |
324 } | |
325 } else { | |
326 warning(_g('line %d of %s is invalid, it has been ignored'), $., $fi
le); | |
327 } | |
328 } | |
329 close($conf_fh); | |
330 } | |
331 | |
332 =item $bf->get($flag) | |
333 | |
334 Return the value associated to the flag. It might be undef if the | |
335 flag doesn't exist. | |
336 | |
337 =cut | |
338 | |
339 sub get { | |
340 my ($self, $key) = @_; | |
341 return $self->{flags}{$key}; | |
342 } | |
343 | |
344 =item $bf->get_feature_areas() | |
345 | |
346 Return the feature areas (i.e. the area values has_features will return | |
347 true for). | |
348 | |
349 =cut | |
350 | |
351 sub get_feature_areas { | |
352 my ($self) = @_; | |
353 return keys %{$self->{features}}; | |
354 } | |
355 | |
356 =item $bf->get_features($area) | |
357 | |
358 Return, for the given area, a hash with keys as feature names, and values | |
359 as booleans indicating whether the feature is enabled or not. | |
360 | |
361 =cut | |
362 | |
363 sub get_features { | |
364 my ($self, $area) = @_; | |
365 return %{$self->{features}{$area}}; | |
366 } | |
367 | |
368 =item $bf->get_origin($flag) | |
369 | |
370 Return the origin associated to the flag. It might be undef if the | |
371 flag doesn't exist. | |
372 | |
373 =cut | |
374 | |
375 sub get_origin { | |
376 my ($self, $key) = @_; | |
377 return $self->{origin}{$key}; | |
378 } | |
379 | |
380 =item $bf->is_maintainer_modified($flag) | |
381 | |
382 Return true if the flag is modified by the maintainer. | |
383 | |
384 =cut | |
385 | |
386 sub is_maintainer_modified { | |
387 my ($self, $key) = @_; | |
388 return $self->{maintainer}{$key}; | |
389 } | |
390 | |
391 =item $bf->has_features($area) | |
392 | |
393 Returns true if the given area of features is known, and false otherwise. | |
394 The only currently recognized area is "hardening". | |
395 | |
396 =cut | |
397 | |
398 sub has_features { | |
399 my ($self, $area) = @_; | |
400 return exists $self->{features}{$area}; | |
401 } | |
402 | |
403 =item $bf->has($option) | |
404 | |
405 Returns a boolean indicating whether the flags exists in the object. | |
406 | |
407 =cut | |
408 | |
409 sub has { | |
410 my ($self, $key) = @_; | |
411 return exists $self->{flags}{$key}; | |
412 } | |
413 | |
414 =item my @flags = $bf->list() | |
415 | |
416 Returns the list of flags stored in the object. | |
417 | |
418 =cut | |
419 | |
420 sub list { | |
421 my ($self) = @_; | |
422 my @list = sort keys %{$self->{flags}}; | |
423 return @list; | |
424 } | |
425 | |
426 =back | |
427 | |
428 =head1 CHANGES | |
429 | |
430 =head2 Version 1.01 | |
431 | |
432 New method: $bf->prepend() very similar to append(). Implement support of | |
433 the prepend operation everywhere. | |
434 | |
435 New method: $bf->load_maintainer_config() that update the build flags | |
436 based on the package maintainer directives. | |
437 | |
438 =head2 Version 1.02 | |
439 | |
440 New methods: $bf->get_features(), $bf->has_features(), $bf->set_feature(). | |
441 | |
442 =head2 Version 1.03 | |
443 | |
444 New method: $bf->get_feature_areas() to list possible values for | |
445 $bf->get_features. | |
446 | |
447 New method $bf->is_maintainer_modified() and new optional parameter to | |
448 $bf->set(), $bf->append(), $bf->prepend(), $bf->strip(). | |
449 | |
450 =head1 AUTHOR | |
451 | |
452 Raphaël Hertzog <hertzog@debian.org> | |
453 | |
454 =cut | |
455 | |
456 1; | |
OLD | NEW |