scripts/Dpkg/BuildOptions.pm

   1 # Copyright © 2007 Frank Lichtenheld <djpig@debian.org>
   2 # Copyright © 2008, 2012-2017 Guillem Jover <guillem@debian.org>
   3 # Copyright © 2010 Raphaël Hertzog <hertzog@debian.org>
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  17
  18 =encoding utf8
  19
  20 =head1 NAME
  21
  22 Dpkg::BuildOptions - parse and update build options
  23
  24 =head1 DESCRIPTION
  25
  26 This class can be used to manipulate options stored
  27 in environment variables like DEB_BUILD_OPTIONS and
  28 DEB_BUILD_MAINT_OPTIONS.
  29
  30 =cut
  31
  32 package Dpkg::BuildOptions 1.02;
  33
  34 use strict;
  35 use warnings;
  36
  37 use List::Util qw(any);
  38
  39 use Dpkg::Gettext;
  40 use Dpkg::ErrorHandling;
  41 use Dpkg::BuildEnv;
  42
  43 =head1 METHODS
  44
  45 =over 4
  46
  47 =item $bo = Dpkg::BuildOptions->new(%opts)
  48
  49 Create a new Dpkg::BuildOptions object. It will be initialized based
  50 on the value of the environment variable named $opts{envvar} (or
  51 DEB_BUILD_OPTIONS if that option is not set).
  52
  53 =cut
  54
  55 sub new {
  56     my ($this, %opts) = @_;
  57     my $class = ref($this) || $this;
  58
  59     my $self = {
  60         options => {},
  61         source => {},
  62         envvar => $opts{envvar} // 'DEB_BUILD_OPTIONS',
  63     };
  64     bless $self, $class;
  65     $self->merge(Dpkg::BuildEnv::get($self->{envvar}), $self->{envvar});
  66     return $self;
  67 }
  68
  69 =item $bo->reset()
  70
  71 Reset the object to not have any option (it's empty).
  72
  73 =cut
  74
  75 sub reset {
  76     my $self = shift;
  77     $self->{options} = {};
  78     $self->{source} = {};
  79 }
  80
  81 =item $bo->merge($content, $source)
  82
  83 Merge the options set in $content and record that they come from the
  84 source $source. $source is mainly used in warning messages currently
  85 to indicate where invalid options have been detected.
  86
  87 $content is a space separated list of options with optional assigned
  88 values like "nocheck parallel=2".
  89
  90 =cut
  91
  92 sub merge {
  93     my ($self, $content, $source) = @_;
  94     return 0 unless defined $content;
  95     my $count = 0;
  96     foreach (split(/\s+/, $content)) {
  97         unless (/^([a-z][a-z0-9_-]*)(?:=(\S*))?$/) {
  98             warning(g_('invalid flag in %s: %s'), $source, $_);
  99             next;
 100         }
 101         ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
 102         $count += $self->set($1, $2, $source);
 103     }
 104     return $count;
 105 }
 106
 107 =item $bo->set($option, $value, [$source])
 108
 109 Store the given option in the object with the given value. It's legitimate
 110 for a value to be undefined if the option is a simple boolean (its
 111 presence means true, its absence means false). The $source is optional
 112 and indicates where the option comes from.
 113
 114 The known options have their values checked for sanity. Options without
 115 values have their value removed and options with invalid values are
 116 discarded.
 117
 118 =cut
 119
 120 sub set {
 121     my ($self, $key, $value, $source) = @_;
 122
 123     # Sanity checks
 124     if (any { $_ eq $key } qw(terse noopt nostrip nocheck) and defined $value) {
 125         $value = undef;
 126     } elsif ($key eq 'parallel')  {
 127         $value //= '';
 128         return 0 if $value !~ /^\d*$/;
 129     }
 130
 131     $self->{options}{$key} = $value;
 132     $self->{source}{$key} = $source;
 133
 134     return 1;
 135 }
 136
 137 =item $bo->get($option)
 138
 139 Return the value associated to the option. It might be undef even if the
 140 option exists. You might want to check with $bo->has($option) to verify if
 141 the option is stored in the object.
 142
 143 =cut
 144
 145 sub get {
 146     my ($self, $key) = @_;
 147     return $self->{options}{$key};
 148 }
 149
 150 =item $bo->has($option)
 151
 152 Returns a boolean indicating whether the option is stored in the object.
 153
 154 =cut
 155
 156 sub has {
 157     my ($self, $key) = @_;
 158     return exists $self->{options}{$key};
 159 }
 160
 161 =item $bo->parse_features($option, $use_feature)
 162
 163 Parse the $option values, as a set of known features to enable or disable,
 164 as specified in the $use_feature hash reference.
 165
 166 Each feature is prefixed with a 'B<+>' or a 'B<->' character as a marker
 167 to enable or disable it. The special feature "B<all>" can be used to act
 168 on all known features.
 169
 170 Unknown or malformed features will emit warnings.
 171
 172 =cut
 173
 174 sub parse_features {
 175     my ($self, $option, $use_feature) = @_;
 176
 177     foreach my $feature (split(/,/, $self->get($option) // '')) {
 178         $feature = lc $feature;
 179         if ($feature =~ s/^([+-])//) {
 180             my $value = ($1 eq '+') ? 1 : 0;
 181             if ($feature eq 'all') {
 182                 $use_feature->{$_} = $value foreach keys %{$use_feature};
 183             } else {
 184                 if (exists $use_feature->{$feature}) {
 185                     $use_feature->{$feature} = $value;
 186                 } else {
 187                     warning(g_('unknown %s feature in %s variable: %s'),
 188                             $option, $self->{envvar}, $feature);
 189                 }
 190             }
 191         } else {
 192             warning(g_('incorrect value in %s option of %s variable: %s'),
 193                     $option, $self->{envvar}, $feature);
 194         }
 195     }
 196 }
 197
 198 =item $string = $bo->output($fh)
 199
 200 Return a string representation of the build options suitable to be
 201 assigned to an environment variable. Can optionally output that string to
 202 the given filehandle.
 203
 204 =cut
 205
 206 sub output {
 207     my ($self, $fh) = @_;
 208     my $o = $self->{options};
 209     my $res = join(' ', map { defined($o->{$_}) ? $_ . '=' . $o->{$_} : $_ } sort keys %$o);
 210     print { $fh } $res if defined $fh;
 211     return $res;
 212 }
 213
 214 =item $bo->export([$var])
 215
 216 Export the build options to the given environment variable. If omitted,
 217 the environment variable defined at creation time is assumed. The value
 218 set to the variable is also returned.
 219
 220 =cut
 221
 222 sub export {
 223     my ($self, $var) = @_;
 224     $var //= $self->{envvar};
 225     my $content = $self->output();
 226     Dpkg::BuildEnv::set($var, $content);
 227     return $content;
 228 }
 229
 230 =back
 231
 232 =head1 CHANGES
 233
 234 =head2 Version 1.02 (dpkg 1.18.19)
 235
 236 New method: $bo->parse_features().
 237
 238 =head2 Version 1.01 (dpkg 1.16.1)
 239
 240 Enable to use another environment variable instead of DEB_BUILD_OPTIONS.
 241 Thus add support for the "envvar" option at creation time.
 242
 243 =head2 Version 1.00 (dpkg 1.15.6)
 244
 245 Mark the module as public.
 246
 247 =cut
 248
 249 1;