scripts/Dpkg/BuildFlags.pm

   1 # Copyright © 2010-2011 Raphaël Hertzog <hertzog@debian.org>
   2 # Copyright © 2012-2022 Guillem Jover <guillem@debian.org>
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  16
  17 =encoding utf8
  18
  19 =head1 NAME
  20
  21 Dpkg::BuildFlags - query build flags
  22
  23 =head1 DESCRIPTION
  24
  25 This class is used by dpkg-buildflags and can be used
  26 to query the same information.
  27
  28 =cut
  29
  30 package Dpkg::BuildFlags 1.06;
  31
  32 use strict;
  33 use warnings;
  34
  35 use Dpkg ();
  36 use Dpkg::Gettext;
  37 use Dpkg::BuildEnv;
  38 use Dpkg::ErrorHandling;
  39 use Dpkg::Vendor qw(run_vendor_hook);
  40
  41 =head1 METHODS
  42
  43 =over 4
  44
  45 =item $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 If the option B<vendor_defaults> is set to false, then no vendor defaults are
  51 initialized (it defaults to true).
  52
  53 =cut
  54
  55 sub new {
  56     my ($this, %opts) = @_;
  57     my $class = ref($this) || $this;
  58
  59     my $self = {
  60     };
  61     bless $self, $class;
  62
  63     $opts{vendor_defaults} //= 1;
  64
  65     if ($opts{vendor_defaults}) {
  66         $self->load_vendor_defaults();
  67     } else {
  68         $self->_init_vendor_defaults();
  69     }
  70     return $self;
  71 }
  72
  73 sub _init_vendor_defaults {
  74     my $self = shift;
  75
  76     my @flags = qw(
  77         ASFLAGS
  78         ASFLAGS_FOR_BUILD
  79         CPPFLAGS
  80         CPPFLAGS_FOR_BUILD
  81         CFLAGS
  82         CFLAGS_FOR_BUILD
  83         CXXFLAGS
  84         CXXFLAGS_FOR_BUILD
  85         OBJCFLAGS
  86         OBJCFLAGS_FOR_BUILD
  87         OBJCXXFLAGS
  88         OBJCXXFLAGS_FOR_BUILD
  89         DFLAGS
  90         DFLAGS_FOR_BUILD
  91         FFLAGS
  92         FFLAGS_FOR_BUILD
  93         FCFLAGS
  94         FCFLAGS_FOR_BUILD
  95         LDFLAGS
  96         LDFLAGS_FOR_BUILD
  97     );
  98
  99     $self->{features} = {};
 100     $self->{builtins} = {};
 101     $self->{optvals} = {};
 102     $self->{flags} = { map { $_ => '' } @flags };
 103     $self->{origin} = { map { $_ => 'vendor' } @flags };
 104     $self->{maintainer} = { map { $_ => 0 } @flags };
 105 }
 106
 107 =item $bf->load_vendor_defaults()
 108
 109 Reset the flags stored to the default set provided by the vendor.
 110
 111 =cut
 112
 113 sub load_vendor_defaults {
 114     my $self = shift;
 115
 116     $self->_init_vendor_defaults();
 117
 118     # The vendor hook will add the feature areas build flags.
 119     run_vendor_hook('update-buildflags', $self);
 120 }
 121
 122 =item $bf->load_system_config()
 123
 124 Update flags from the system configuration.
 125
 126 =cut
 127
 128 sub load_system_config {
 129     my $self = shift;
 130
 131     $self->update_from_conffile("$Dpkg::CONFDIR/buildflags.conf", 'system');
 132 }
 133
 134 =item $bf->load_user_config()
 135
 136 Update flags from the user configuration.
 137
 138 =cut
 139
 140 sub load_user_config {
 141     my $self = shift;
 142
 143     my $confdir = $ENV{XDG_CONFIG_HOME};
 144     $confdir ||= $ENV{HOME} . '/.config' if length $ENV{HOME};
 145     if (length $confdir) {
 146         $self->update_from_conffile("$confdir/dpkg/buildflags.conf", 'user');
 147     }
 148 }
 149
 150 =item $bf->load_environment_config()
 151
 152 Update flags based on user directives stored in the environment. See
 153 L<dpkg-buildflags(1)> for details.
 154
 155 =cut
 156
 157 sub load_environment_config {
 158     my $self = shift;
 159
 160     foreach my $flag (keys %{$self->{flags}}) {
 161         my $envvar = 'DEB_' . $flag . '_SET';
 162         if (Dpkg::BuildEnv::has($envvar)) {
 163             $self->set($flag, Dpkg::BuildEnv::get($envvar), 'env');
 164         }
 165         $envvar = 'DEB_' . $flag . '_STRIP';
 166         if (Dpkg::BuildEnv::has($envvar)) {
 167             $self->strip($flag, Dpkg::BuildEnv::get($envvar), 'env');
 168         }
 169         $envvar = 'DEB_' . $flag . '_APPEND';
 170         if (Dpkg::BuildEnv::has($envvar)) {
 171             $self->append($flag, Dpkg::BuildEnv::get($envvar), 'env');
 172         }
 173         $envvar = 'DEB_' . $flag . '_PREPEND';
 174         if (Dpkg::BuildEnv::has($envvar)) {
 175             $self->prepend($flag, Dpkg::BuildEnv::get($envvar), 'env');
 176         }
 177     }
 178 }
 179
 180 =item $bf->load_maintainer_config()
 181
 182 Update flags based on maintainer directives stored in the environment. See
 183 L<dpkg-buildflags(1)> for details.
 184
 185 =cut
 186
 187 sub load_maintainer_config {
 188     my $self = shift;
 189
 190     foreach my $flag (keys %{$self->{flags}}) {
 191         my $envvar = 'DEB_' . $flag . '_MAINT_SET';
 192         if (Dpkg::BuildEnv::has($envvar)) {
 193             $self->set($flag, Dpkg::BuildEnv::get($envvar), undef, 1);
 194         }
 195         $envvar = 'DEB_' . $flag . '_MAINT_STRIP';
 196         if (Dpkg::BuildEnv::has($envvar)) {
 197             $self->strip($flag, Dpkg::BuildEnv::get($envvar), undef, 1);
 198         }
 199         $envvar = 'DEB_' . $flag . '_MAINT_APPEND';
 200         if (Dpkg::BuildEnv::has($envvar)) {
 201             $self->append($flag, Dpkg::BuildEnv::get($envvar), undef, 1);
 202         }
 203         $envvar = 'DEB_' . $flag . '_MAINT_PREPEND';
 204         if (Dpkg::BuildEnv::has($envvar)) {
 205             $self->prepend($flag, Dpkg::BuildEnv::get($envvar), undef, 1);
 206         }
 207     }
 208 }
 209
 210
 211 =item $bf->load_config()
 212
 213 Call successively load_system_config(), load_user_config(),
 214 load_environment_config() and load_maintainer_config() to update the
 215 default build flags defined by the vendor.
 216
 217 =cut
 218
 219 sub load_config {
 220     my $self = shift;
 221
 222     $self->load_system_config();
 223     $self->load_user_config();
 224     $self->load_environment_config();
 225     $self->load_maintainer_config();
 226 }
 227
 228 =item $bf->unset($flag)
 229
 230 Unset the build flag $flag, so that it will not be known anymore.
 231
 232 =cut
 233
 234 sub unset {
 235     my ($self, $flag) = @_;
 236
 237     delete $self->{flags}->{$flag};
 238     delete $self->{origin}->{$flag};
 239     delete $self->{maintainer}->{$flag};
 240 }
 241
 242 =item $bf->set($flag, $value, $source, $maint)
 243
 244 Update the build flag $flag with value $value and record its origin as
 245 $source (if defined). Record it as maintainer modified if $maint is
 246 defined and true.
 247
 248 =cut
 249
 250 sub set {
 251     my ($self, $flag, $value, $src, $maint) = @_;
 252     $self->{flags}->{$flag} = $value;
 253     $self->{origin}->{$flag} = $src if defined $src;
 254     $self->{maintainer}->{$flag} = $maint if $maint;
 255 }
 256
 257 =item $bf->set_feature($area, $feature, $enabled)
 258
 259 Update the boolean state of whether a specific feature within a known
 260 feature area has been enabled. The only currently known feature areas
 261 are "future", "qa", "sanitize", "optimize", "hardening" and "reproducible".
 262
 263 =cut
 264
 265 sub set_feature {
 266     my ($self, $area, $feature, $enabled) = @_;
 267     $self->{features}{$area}{$feature} = $enabled;
 268 }
 269
 270 =item $bf->get_feature($area, $feature)
 271
 272 Returns the value for the given feature within a known feature area.
 273 This is relevant for builtin features where the feature has a ternary
 274 state of true, false and undef, and where the latter cannot be retrieved
 275 with use_feature().
 276
 277 =cut
 278
 279 sub get_feature {
 280     my ($self, $area, $feature) = @_;
 281
 282     return if ! $self->has_features($area);
 283     return $self->{features}{$area}{$feature};
 284 }
 285
 286 =item $bf->use_feature($area, $feature)
 287
 288 Returns true if the given feature within a known feature areas has been
 289 enabled, and false otherwise.
 290 The only currently recognized feature areas are "future", "qa", "sanitize",
 291 "optimize", "hardening" and "reproducible".
 292
 293 =cut
 294
 295 sub use_feature {
 296     my ($self, $area, $feature) = @_;
 297
 298     return 0 if ! $self->has_features($area);
 299     return 0 if ! $self->{features}{$area}{$feature};
 300     return 1;
 301 }
 302
 303 =item $bf->set_builtin($area, $feature, $enabled)
 304
 305 Update the boolean state of whether a specific feature within a known
 306 feature area is handled (even if only in some architectures) as a builtin
 307 default by the compiler.
 308
 309 =cut
 310
 311 sub set_builtin {
 312     my ($self, $area, $feature, $enabled) = @_;
 313     $self->{builtins}{$area}{$feature} = $enabled;
 314 }
 315
 316 =item $bf->get_builtins($area)
 317
 318 Return, for the given area, a hash with keys as feature names, and values
 319 as booleans indicating whether the feature is handled as a builtin default
 320 by the compiler or not. Only features that might be handled as builtins on
 321 some architectures are returned as part of the hash. Missing features mean
 322 they are currently never handled as builtins by the compiler.
 323
 324 =cut
 325
 326 sub get_builtins {
 327     my ($self, $area) = @_;
 328     return if ! exists $self->{builtins}{$area};
 329     return %{$self->{builtins}{$area}};
 330 }
 331
 332 =item $bf->set_option_value($option, $value)
 333
 334 B<Private> method to set the value of a build option.
 335 Do not use outside of the dpkg project.
 336
 337 =cut
 338
 339 sub set_option_value {
 340     my ($self, $option, $value) = @_;
 341
 342     $self->{optvals}{$option} = $value;
 343 }
 344
 345 =item $bf->get_option_value($option)
 346
 347 B<Private> method to get the value of a build option.
 348 Do not use outside of the dpkg project.
 349
 350 =cut
 351
 352 sub get_option_value {
 353     my ($self, $option) = @_;
 354
 355     return $self->{optvals}{$option};
 356 }
 357
 358 =item $bf->strip($flag, $value, $source, $maint)
 359
 360 Update the build flag $flag by stripping the flags listed in $value and
 361 record its origin as $source (if defined). Record it as maintainer modified
 362 if $maint is defined and true.
 363
 364 =cut
 365
 366 sub strip {
 367     my ($self, $flag, $value, $src, $maint) = @_;
 368
 369     my %strip = map { $_ => 1 } split /\s+/, $value;
 370
 371     $self->{flags}->{$flag} = join q{ }, grep {
 372         ! exists $strip{$_}
 373     } split q{ }, $self->{flags}{$flag};
 374     $self->{origin}->{$flag} = $src if defined $src;
 375     $self->{maintainer}->{$flag} = $maint if $maint;
 376 }
 377
 378 =item $bf->append($flag, $value, $source, $maint)
 379
 380 Append the options listed in $value to the current value of the flag $flag.
 381 Record its origin as $source (if defined). Record it as maintainer modified
 382 if $maint is defined and true.
 383
 384 =cut
 385
 386 sub append {
 387     my ($self, $flag, $value, $src, $maint) = @_;
 388     if (length($self->{flags}->{$flag})) {
 389         $self->{flags}->{$flag} .= " $value";
 390     } else {
 391         $self->{flags}->{$flag} = $value;
 392     }
 393     $self->{origin}->{$flag} = $src if defined $src;
 394     $self->{maintainer}->{$flag} = $maint if $maint;
 395 }
 396
 397 =item $bf->prepend($flag, $value, $source, $maint)
 398
 399 Prepend the options listed in $value to the current value of the flag $flag.
 400 Record its origin as $source (if defined). Record it as maintainer modified
 401 if $maint is defined and true.
 402
 403 =cut
 404
 405 sub prepend {
 406     my ($self, $flag, $value, $src, $maint) = @_;
 407     if (length($self->{flags}->{$flag})) {
 408         $self->{flags}->{$flag} = "$value " . $self->{flags}->{$flag};
 409     } else {
 410         $self->{flags}->{$flag} = $value;
 411     }
 412     $self->{origin}->{$flag} = $src if defined $src;
 413     $self->{maintainer}->{$flag} = $maint if $maint;
 414 }
 415
 416
 417 =item $bf->update_from_conffile($file, $source)
 418
 419 Update the current build flags based on the configuration directives
 420 contained in $file. See L<dpkg-buildflags(1)> for the format of the directives.
 421
 422 $source is the origin recorded for any build flag set or modified.
 423
 424 =cut
 425
 426 sub update_from_conffile {
 427     my ($self, $file, $src) = @_;
 428     local $_;
 429
 430     return unless -e $file;
 431     open(my $conf_fh, '<', $file) or syserr(g_('cannot read %s'), $file);
 432     while (<$conf_fh>) {
 433         chomp;
 434         next if /^\s*#/; # Skip comments
 435         next if /^\s*$/; # Skip empty lines
 436         if (/^(append|prepend|set|strip)\s+(\S+)\s+(\S.*\S)\s*$/i) {
 437             my ($op, $flag, $value) = ($1, $2, $3);
 438             unless (exists $self->{flags}->{$flag}) {
 439                 warning(g_('line %d of %s mentions unknown flag %s'), $., $file, $flag);
 440                 $self->{flags}->{$flag} = '';
 441             }
 442             if (lc($op) eq 'set') {
 443                 $self->set($flag, $value, $src);
 444             } elsif (lc($op) eq 'strip') {
 445                 $self->strip($flag, $value, $src);
 446             } elsif (lc($op) eq 'append') {
 447                 $self->append($flag, $value, $src);
 448             } elsif (lc($op) eq 'prepend') {
 449                 $self->prepend($flag, $value, $src);
 450             }
 451         } else {
 452             warning(g_('line %d of %s is invalid, it has been ignored'), $., $file);
 453         }
 454     }
 455     close($conf_fh);
 456 }
 457
 458 =item $bf->get($flag)
 459
 460 Return the value associated to the flag. It might be undef if the
 461 flag doesn't exist.
 462
 463 =cut
 464
 465 sub get {
 466     my ($self, $key) = @_;
 467     return $self->{flags}{$key};
 468 }
 469
 470 =item $bf->get_feature_areas()
 471
 472 Return the feature areas (i.e. the area values has_features will return
 473 true for).
 474
 475 =cut
 476
 477 sub get_feature_areas {
 478     my $self = shift;
 479
 480     return keys %{$self->{features}};
 481 }
 482
 483 =item $bf->get_features($area)
 484
 485 Return, for the given area, a hash with keys as feature names, and values
 486 as booleans indicating whether the feature is enabled or not.
 487
 488 =cut
 489
 490 sub get_features {
 491     my ($self, $area) = @_;
 492     return %{$self->{features}{$area}};
 493 }
 494
 495 =item $bf->get_origin($flag)
 496
 497 Return the origin associated to the flag. It might be undef if the
 498 flag doesn't exist.
 499
 500 =cut
 501
 502 sub get_origin {
 503     my ($self, $key) = @_;
 504     return $self->{origin}{$key};
 505 }
 506
 507 =item $bf->is_maintainer_modified($flag)
 508
 509 Return true if the flag is modified by the maintainer.
 510
 511 =cut
 512
 513 sub is_maintainer_modified {
 514     my ($self, $key) = @_;
 515     return $self->{maintainer}{$key};
 516 }
 517
 518 =item $bf->has_features($area)
 519
 520 Returns true if the given area of features is known, and false otherwise.
 521 The only currently recognized feature areas are "future", "qa", "sanitize",
 522 "optimize", "hardening" and "reproducible".
 523
 524 =cut
 525
 526 sub has_features {
 527     my ($self, $area) = @_;
 528     return exists $self->{features}{$area};
 529 }
 530
 531 =item $bf->has($option)
 532
 533 Returns a boolean indicating whether the flags exists in the object.
 534
 535 =cut
 536
 537 sub has {
 538     my ($self, $key) = @_;
 539     return exists $self->{flags}{$key};
 540 }
 541
 542 =item @flags = $bf->list()
 543
 544 Returns the list of flags stored in the object.
 545
 546 =cut
 547
 548 sub list {
 549     my $self = shift;
 550     my @list = sort keys %{$self->{flags}};
 551     return @list;
 552 }
 553
 554 =back
 555
 556 =head1 CHANGES
 557
 558 =head2 Version 1.06 (dpkg 1.21.15)
 559
 560 New method: $bf->get_feature().
 561
 562 =head2 Version 1.05 (dpkg 1.21.14)
 563
 564 New option: 'vendor_defaults' in new().
 565
 566 New methods: $bf->load_vendor_defaults(), $bf->use_feature(),
 567 $bf->set_builtin(), $bf->get_builtins().
 568
 569 =head2 Version 1.04 (dpkg 1.20.0)
 570
 571 New method: $bf->unset().
 572
 573 =head2 Version 1.03 (dpkg 1.16.5)
 574
 575 New method: $bf->get_feature_areas() to list possible values for
 576 $bf->get_features.
 577
 578 New method $bf->is_maintainer_modified() and new optional parameter to
 579 $bf->set(), $bf->append(), $bf->prepend(), $bf->strip().
 580
 581 =head2 Version 1.02 (dpkg 1.16.2)
 582
 583 New methods: $bf->get_features(), $bf->has_features(), $bf->set_feature().
 584
 585 =head2 Version 1.01 (dpkg 1.16.1)
 586
 587 New method: $bf->prepend() very similar to append(). Implement support of
 588 the prepend operation everywhere.
 589
 590 New method: $bf->load_maintainer_config() that update the build flags
 591 based on the package maintainer directives.
 592
 593 =head2 Version 1.00 (dpkg 1.15.7)
 594
 595 Mark the module as public.
 596
 597 =cut
 598
 599 1;