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