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