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