| OLD | NEW |
|---|
| (Empty) |
| 1 # Copyright © 2006-2009,2012 Guillem Jover <guillem@debian.org> | |
| 2 # Copyright © 2007-2010 Raphaël Hertzog <hertzog@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::Substvars; | |
| 18 | |
| 19 use strict; | |
| 20 use warnings; | |
| 21 | |
| 22 our $VERSION = '1.02'; | |
| 23 | |
| 24 use Dpkg (); | |
| 25 use Dpkg::Arch qw(get_host_arch); | |
| 26 use Dpkg::ErrorHandling; | |
| 27 use Dpkg::Gettext; | |
| 28 | |
| 29 use Carp; | |
| 30 use POSIX qw(:errno_h); | |
| 31 | |
| 32 use parent qw(Dpkg::Interface::Storable); | |
| 33 | |
| 34 my $maxsubsts = 50; | |
| 35 | |
| 36 =encoding utf8 | |
| 37 | |
| 38 =head1 NAME | |
| 39 | |
| 40 Dpkg::Substvars - handle variable substitution in strings | |
| 41 | |
| 42 =head1 DESCRIPTION | |
| 43 | |
| 44 It provides some an object which is able to substitute variables in | |
| 45 strings. | |
| 46 | |
| 47 =head1 METHODS | |
| 48 | |
| 49 =over 8 | |
| 50 | |
| 51 =item my $s = Dpkg::Substvars->new($file) | |
| 52 | |
| 53 Create a new object that can do substitutions. By default it contains | |
| 54 generic substitutions like ${Newline}, ${Space}, ${Tab}, ${dpkg:Version} | |
| 55 and ${dpkg:Upstream-Version}. | |
| 56 | |
| 57 Additional substitutions will be read from the $file passed as parameter. | |
| 58 | |
| 59 It keeps track of which substitutions were actually used (only counting | |
| 60 substvars(), not get()), and warns about unused substvars when asked to. The | |
| 61 substitutions that are always present are not included in these warnings. | |
| 62 | |
| 63 =cut | |
| 64 | |
| 65 sub new { | |
| 66 my ($this, $arg) = @_; | |
| 67 my $class = ref($this) || $this; | |
| 68 my $self = { | |
| 69 vars => { | |
| 70 'Newline' => "\n", | |
| 71 'Space' => ' ', | |
| 72 'Tab' => "\t", | |
| 73 'dpkg:Version' => $Dpkg::PROGVERSION, | |
| 74 'dpkg:Upstream-Version' => $Dpkg::PROGVERSION, | |
| 75 }, | |
| 76 used => {}, | |
| 77 msg_prefix => '', | |
| 78 }; | |
| 79 $self->{vars}{'dpkg:Upstream-Version'} =~ s/-[^-]+$//; | |
| 80 bless $self, $class; | |
| 81 $self->mark_as_used($_) foreach keys %{$self->{vars}}; | |
| 82 if ($arg) { | |
| 83 $self->load($arg) if -e $arg; | |
| 84 } | |
| 85 return $self; | |
| 86 } | |
| 87 | |
| 88 =item $s->set($key, $value) | |
| 89 | |
| 90 Add/replace a substitution. | |
| 91 | |
| 92 =cut | |
| 93 | |
| 94 sub set { | |
| 95 my ($self, $key, $value) = @_; | |
| 96 $self->{vars}{$key} = $value; | |
| 97 } | |
| 98 | |
| 99 =item $s->set_as_used($key, $value) | |
| 100 | |
| 101 Add/replace a substitution and mark it as used (no warnings will be produced | |
| 102 even if unused). | |
| 103 | |
| 104 =cut | |
| 105 | |
| 106 sub set_as_used { | |
| 107 my ($self, $key, $value) = @_; | |
| 108 $self->set($key, $value); | |
| 109 $self->mark_as_used($key); | |
| 110 } | |
| 111 | |
| 112 =item $s->get($key) | |
| 113 | |
| 114 Get the value of a given substitution. | |
| 115 | |
| 116 =cut | |
| 117 | |
| 118 sub get { | |
| 119 my ($self, $key) = @_; | |
| 120 return $self->{vars}{$key}; | |
| 121 } | |
| 122 | |
| 123 =item $s->delete($key) | |
| 124 | |
| 125 Remove a given substitution. | |
| 126 | |
| 127 =cut | |
| 128 | |
| 129 sub delete { | |
| 130 my ($self, $key) = @_; | |
| 131 delete $self->{used}{$key}; | |
| 132 return delete $self->{vars}{$key}; | |
| 133 } | |
| 134 | |
| 135 =item $s->mark_as_used($key) | |
| 136 | |
| 137 Prevents warnings about a unused substitution, for example if it is provided by | |
| 138 default. | |
| 139 | |
| 140 =cut | |
| 141 | |
| 142 sub mark_as_used { | |
| 143 my ($self, $key) = @_; | |
| 144 $self->{used}{$key}++; | |
| 145 } | |
| 146 | |
| 147 =item $s->no_warn($key) | |
| 148 | |
| 149 Obsolete function, use mark_as_used() instead. | |
| 150 | |
| 151 =cut | |
| 152 | |
| 153 sub no_warn { | |
| 154 my ($self, $key) = @_; | |
| 155 carp 'obsolete no_warn() function, use mark_as_used() instead'; | |
| 156 $self->mark_as_used($key); | |
| 157 } | |
| 158 | |
| 159 =item $s->load($file) | |
| 160 | |
| 161 Add new substitutions read from $file. | |
| 162 | |
| 163 =item $s->parse($fh, $desc) | |
| 164 | |
| 165 Add new substitutions read from the filehandle. $desc is used to identify | |
| 166 the filehandle in error messages. | |
| 167 | |
| 168 =cut | |
| 169 | |
| 170 sub parse { | |
| 171 my ($self, $fh, $varlistfile) = @_; | |
| 172 binmode($fh); | |
| 173 while (<$fh>) { | |
| 174 next if m/^\s*\#/ || !m/\S/; | |
| 175 s/\s*\n$//; | |
| 176 if (! m/^(\w[-:0-9A-Za-z]*)\=(.*)$/) { | |
| 177 error(_g('bad line in substvars file %s at line %d'), | |
| 178 $varlistfile, $.); | |
| 179 } | |
| 180 $self->{vars}{$1} = $2; | |
| 181 } | |
| 182 } | |
| 183 | |
| 184 =item $s->set_version_substvars($sourceversion, $binaryversion) | |
| 185 | |
| 186 Defines ${binary:Version}, ${source:Version} and | |
| 187 ${source:Upstream-Version} based on the given version strings. | |
| 188 | |
| 189 These will never be warned about when unused. | |
| 190 | |
| 191 =cut | |
| 192 | |
| 193 sub set_version_substvars { | |
| 194 my ($self, $sourceversion, $binaryversion) = @_; | |
| 195 | |
| 196 # Handle old function signature taking only one argument. | |
| 197 $binaryversion ||= $sourceversion; | |
| 198 | |
| 199 # For backwards compatibility on binNMUs that do not use the Binary-Only | |
| 200 # field on the changelog, always fix up the source version. | |
| 201 $sourceversion =~ s/\+b[0-9]+$//; | |
| 202 | |
| 203 $self->{vars}{'binary:Version'} = $binaryversion; | |
| 204 $self->{vars}{'source:Version'} = $sourceversion; | |
| 205 $self->{vars}{'source:Upstream-Version'} = $sourceversion; | |
| 206 $self->{vars}{'source:Upstream-Version'} =~ s/-[^-]*$//; | |
| 207 | |
| 208 # XXX: Source-Version is now deprecated, remove in the future. | |
| 209 $self->{vars}{'Source-Version'} = $binaryversion; | |
| 210 | |
| 211 $self->mark_as_used($_) foreach qw/binary:Version source:Version source:Upst
ream-Version Source-Version/; | |
| 212 } | |
| 213 | |
| 214 =item $s->set_arch_substvars() | |
| 215 | |
| 216 Defines architecture variables: ${Arch}. | |
| 217 | |
| 218 This will never be warned about when unused. | |
| 219 | |
| 220 =cut | |
| 221 | |
| 222 sub set_arch_substvars { | |
| 223 my ($self) = @_; | |
| 224 | |
| 225 $self->set_as_used('Arch', get_host_arch()); | |
| 226 } | |
| 227 | |
| 228 =item $newstring = $s->substvars($string) | |
| 229 | |
| 230 Substitutes variables in $string and return the result in $newstring. | |
| 231 | |
| 232 =cut | |
| 233 | |
| 234 sub substvars { | |
| 235 my ($self, $v, %opts) = @_; | |
| 236 my $lhs; | |
| 237 my $vn; | |
| 238 my $rhs = ''; | |
| 239 my $count = 0; | |
| 240 $opts{msg_prefix} = $self->{msg_prefix} unless exists $opts{msg_prefix}; | |
| 241 $opts{no_warn} = 0 unless exists $opts{no_warn}; | |
| 242 | |
| 243 while ($v =~ m/^(.*?)\$\{([-:0-9a-z]+)\}(.*)$/si) { | |
| 244 # If we have consumed more from the leftover data, then | |
| 245 # reset the recursive counter. | |
| 246 $count = 0 if (length($3) < length($rhs)); | |
| 247 | |
| 248 if ($count >= $maxsubsts) { | |
| 249 error($opts{msg_prefix} . | |
| 250 _g("too many substitutions - recursive ? - in \`%s'"), $v); | |
| 251 } | |
| 252 $lhs = $1; $vn = $2; $rhs = $3; | |
| 253 if (defined($self->{vars}{$vn})) { | |
| 254 $v = $lhs . $self->{vars}{$vn} . $rhs; | |
| 255 $self->mark_as_used($vn); | |
| 256 $count++; | |
| 257 } else { | |
| 258 warning($opts{msg_prefix} . _g('unknown substitution variable ${%s}'
), | |
| 259 $vn) unless $opts{no_warn}; | |
| 260 $v = $lhs . $rhs; | |
| 261 } | |
| 262 } | |
| 263 return $v; | |
| 264 } | |
| 265 | |
| 266 =item $s->warn_about_unused() | |
| 267 | |
| 268 Issues warning about any variables that were set, but not used | |
| 269 | |
| 270 =cut | |
| 271 | |
| 272 sub warn_about_unused { | |
| 273 my ($self, %opts) = @_; | |
| 274 $opts{msg_prefix} = $self->{msg_prefix} unless exists $opts{msg_prefix}; | |
| 275 | |
| 276 foreach my $vn (keys %{$self->{vars}}) { | |
| 277 next if $self->{used}{$vn}; | |
| 278 # Empty substitutions variables are ignored on the basis | |
| 279 # that they are not required in the current situation | |
| 280 # (example: debhelper's misc:Depends in many cases) | |
| 281 next if $self->{vars}{$vn} eq ''; | |
| 282 warning($opts{msg_prefix} . _g('unused substitution variable ${%s}'), | |
| 283 $vn); | |
| 284 } | |
| 285 } | |
| 286 | |
| 287 =item $s->set_msg_prefix($prefix) | |
| 288 | |
| 289 Define a prefix displayed before all warnings/error messages output | |
| 290 by the module. | |
| 291 | |
| 292 =cut | |
| 293 | |
| 294 sub set_msg_prefix { | |
| 295 my ($self, $prefix) = @_; | |
| 296 $self->{msg_prefix} = $prefix; | |
| 297 } | |
| 298 | |
| 299 =item $s->save($file) | |
| 300 | |
| 301 Store all substitutions variables except the automatic ones in the | |
| 302 indicated file. | |
| 303 | |
| 304 =item "$s" | |
| 305 | |
| 306 Return a string representation of all substitutions variables except the | |
| 307 automatic ones. | |
| 308 | |
| 309 =item $str = $s->output($fh) | |
| 310 | |
| 311 Print all substitutions variables except the automatic ones in the | |
| 312 filehandle and return the content written. | |
| 313 | |
| 314 =cut | |
| 315 | |
| 316 sub output { | |
| 317 my ($self, $fh) = @_; | |
| 318 my $str = ''; | |
| 319 # Store all non-automatic substitutions only | |
| 320 foreach my $vn (sort keys %{$self->{vars}}) { | |
| 321 next if /^(?:(?:dpkg|source|binary):(?:Source-)?Version|Space|Tab|Newlin
e|Arch|Source-Version|F:.+)$/; | |
| 322 my $line = "$vn=" . $self->{vars}{$vn} . "\n"; | |
| 323 print { $fh } $line if defined $fh; | |
| 324 $str .= $line; | |
| 325 } | |
| 326 return $str; | |
| 327 } | |
| 328 | |
| 329 =back | |
| 330 | |
| 331 =head1 AUTHOR | |
| 332 | |
| 333 Raphaël Hertzog <hertzog@debian.org>. | |
| 334 | |
| 335 =cut | |
| 336 | |
| 337 1; | |
| OLD | NEW |
|---|
Chromium Code Reviews
Issue 2425693003:
Revert of Linux build: Use sysroot when calculating dependencies (Closed)
