| 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 |