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