1# Copyright © 2006-2009, 2012-2015 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 17package Dpkg::Substvars; 18 19use strict; 20use warnings; 21 22our $VERSION = '1.06'; 23 24use Dpkg (); 25use Dpkg::Arch qw(get_host_arch); 26use Dpkg::Version; 27use Dpkg::ErrorHandling; 28use Dpkg::Gettext; 29 30use parent qw(Dpkg::Interface::Storable); 31 32my $maxsubsts = 50; 33 34=encoding utf8 35 36=head1 NAME 37 38Dpkg::Substvars - handle variable substitution in strings 39 40=head1 DESCRIPTION 41 42It provides an object which is able to substitute variables in strings. 43 44=cut 45 46use constant { 47 SUBSTVAR_ATTR_USED => 1, 48 SUBSTVAR_ATTR_AUTO => 2, 49 SUBSTVAR_ATTR_AGED => 4, 50}; 51 52=head1 METHODS 53 54=over 8 55 56=item $s = Dpkg::Substvars->new($file) 57 58Create a new object that can do substitutions. By default it contains 59generic substitutions like ${Newline}, ${Space}, ${Tab}, ${dpkg:Version} 60and ${dpkg:Upstream-Version}. 61 62Additional substitutions will be read from the $file passed as parameter. 63 64It keeps track of which substitutions were actually used (only counting 65substvars(), not get()), and warns about unused substvars when asked to. The 66substitutions that are always present are not included in these warnings. 67 68=cut 69 70sub new { 71 my ($this, $arg) = @_; 72 my $class = ref($this) || $this; 73 my $self = { 74 vars => { 75 'Newline' => "\n", 76 'Space' => ' ', 77 'Tab' => "\t", 78 'dpkg:Version' => $Dpkg::PROGVERSION, 79 'dpkg:Upstream-Version' => $Dpkg::PROGVERSION, 80 }, 81 attr => {}, 82 msg_prefix => '', 83 }; 84 $self->{vars}{'dpkg:Upstream-Version'} =~ s/-[^-]+$//; 85 bless $self, $class; 86 87 my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; 88 $self->{attr}{$_} = $attr foreach keys %{$self->{vars}}; 89 if ($arg) { 90 $self->load($arg) if -e $arg; 91 } 92 return $self; 93} 94 95=item $s->set($key, $value) 96 97Add/replace a substitution. 98 99=cut 100 101sub set { 102 my ($self, $key, $value, $attr) = @_; 103 104 $attr //= 0; 105 106 $self->{vars}{$key} = $value; 107 $self->{attr}{$key} = $attr; 108} 109 110=item $s->set_as_used($key, $value) 111 112Add/replace a substitution and mark it as used (no warnings will be produced 113even if unused). 114 115=cut 116 117sub set_as_used { 118 my ($self, $key, $value) = @_; 119 120 $self->set($key, $value, SUBSTVAR_ATTR_USED); 121} 122 123=item $s->set_as_auto($key, $value) 124 125Add/replace a substitution and mark it as used and automatic (no warnings 126will be produced even if unused). 127 128=cut 129 130sub set_as_auto { 131 my ($self, $key, $value) = @_; 132 133 $self->set($key, $value, SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO); 134} 135 136=item $s->get($key) 137 138Get the value of a given substitution. 139 140=cut 141 142sub get { 143 my ($self, $key) = @_; 144 return $self->{vars}{$key}; 145} 146 147=item $s->delete($key) 148 149Remove a given substitution. 150 151=cut 152 153sub delete { 154 my ($self, $key) = @_; 155 delete $self->{attr}{$key}; 156 return delete $self->{vars}{$key}; 157} 158 159=item $s->mark_as_used($key) 160 161Prevents warnings about a unused substitution, for example if it is provided by 162default. 163 164=cut 165 166sub mark_as_used { 167 my ($self, $key) = @_; 168 $self->{attr}{$key} |= SUBSTVAR_ATTR_USED; 169} 170 171=item $s->no_warn($key) 172 173Obsolete function, use mark_as_used() instead. 174 175=cut 176 177sub no_warn { 178 my ($self, $key) = @_; 179 180 warnings::warnif('deprecated', 181 'obsolete no_warn() function, use mark_as_used() instead'); 182 183 $self->mark_as_used($key); 184} 185 186=item $s->parse($fh, $desc) 187 188Add new substitutions read from the filehandle. $desc is used to identify 189the filehandle in error messages. 190 191Returns the number of substitutions that have been parsed with success. 192 193=cut 194 195sub parse { 196 my ($self, $fh, $varlistfile) = @_; 197 my $count = 0; 198 local $_; 199 200 binmode($fh); 201 while (<$fh>) { 202 next if m/^\s*\#/ || !m/\S/; 203 s/\s*\n$//; 204 if (! m/^(\w[-:0-9A-Za-z]*)\=(.*)$/) { 205 error(g_('bad line in substvars file %s at line %d'), 206 $varlistfile, $.); 207 } 208 $self->set($1, $2); 209 $count++; 210 } 211 212 return $count 213} 214 215=item $s->load($file) 216 217Add new substitutions read from $file. 218 219=item $s->set_version_substvars($sourceversion, $binaryversion) 220 221Defines ${binary:Version}, ${source:Version} and 222${source:Upstream-Version} based on the given version strings. 223 224These will never be warned about when unused. 225 226=cut 227 228sub set_version_substvars { 229 my ($self, $sourceversion, $binaryversion) = @_; 230 231 # Handle old function signature taking only one argument. 232 $binaryversion //= $sourceversion; 233 234 # For backwards compatibility on binNMUs that do not use the Binary-Only 235 # field on the changelog, always fix up the source version. 236 $sourceversion =~ s/\+b[0-9]+$//; 237 238 my $vs = Dpkg::Version->new($sourceversion, check => 1); 239 if (not defined $vs) { 240 error(g_('invalid source version %s'), $sourceversion); 241 } 242 my $upstreamversion = $vs->as_string(omit_revision => 1); 243 244 my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; 245 246 $self->set('binary:Version', $binaryversion, $attr); 247 $self->set('source:Version', $sourceversion, $attr); 248 $self->set('source:Upstream-Version', $upstreamversion, $attr); 249 250 # XXX: Source-Version is now obsolete, remove in 1.19.x. 251 $self->set('Source-Version', $binaryversion, $attr | SUBSTVAR_ATTR_AGED); 252} 253 254=item $s->set_arch_substvars() 255 256Defines architecture variables: ${Arch}. 257 258This will never be warned about when unused. 259 260=cut 261 262sub set_arch_substvars { 263 my $self = shift; 264 265 my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; 266 267 $self->set('Arch', get_host_arch(), $attr); 268} 269 270=item $s->set_desc_substvars() 271 272Defines source description variables: ${source:Synopsis} and 273${source:Extended-Description}. 274 275These will never be warned about when unused. 276 277=cut 278 279sub set_desc_substvars { 280 my ($self, $desc) = @_; 281 282 my ($synopsis, $extended) = split /\n/, $desc, 2; 283 284 my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO; 285 286 $self->set('source:Synopsis', $synopsis, $attr); 287 $self->set('source:Extended-Description', $extended, $attr); 288} 289 290=item $s->set_field_substvars($ctrl, $prefix) 291 292Defines field variables from a Dpkg::Control object, with each variable 293having the form "${$prefix:$field}". 294 295They will never be warned about when unused. 296 297=cut 298 299sub set_field_substvars { 300 my ($self, $ctrl, $prefix) = @_; 301 302 foreach my $field (keys %{$ctrl}) { 303 $self->set_as_auto("$prefix:$field", $ctrl->{$field}); 304 } 305} 306 307=item $newstring = $s->substvars($string) 308 309Substitutes variables in $string and return the result in $newstring. 310 311=cut 312 313sub substvars { 314 my ($self, $v, %opts) = @_; 315 my $lhs; 316 my $vn; 317 my $rhs = ''; 318 my $count = 0; 319 $opts{msg_prefix} //= $self->{msg_prefix}; 320 $opts{no_warn} //= 0; 321 322 while ($v =~ m/^(.*?)\$\{([-:0-9a-z]+)\}(.*)$/si) { 323 # If we have consumed more from the leftover data, then 324 # reset the recursive counter. 325 $count = 0 if (length($3) < length($rhs)); 326 327 if ($count >= $maxsubsts) { 328 error($opts{msg_prefix} . 329 g_("too many substitutions - recursive ? - in '%s'"), $v); 330 } 331 $lhs = $1; 332 $vn = $2; 333 $rhs = $3; 334 if (defined($self->{vars}{$vn})) { 335 $v = $lhs . $self->{vars}{$vn} . $rhs; 336 $self->mark_as_used($vn); 337 $count++; 338 339 if ($self->{attr}{$vn} & SUBSTVAR_ATTR_AGED) { 340 error($opts{msg_prefix} . 341 g_('obsolete substitution variable ${%s}'), $vn); 342 } 343 } else { 344 warning($opts{msg_prefix} . 345 g_('substitution variable ${%s} used, but is not defined'), 346 $vn) unless $opts{no_warn}; 347 $v = $lhs . $rhs; 348 } 349 } 350 return $v; 351} 352 353=item $s->warn_about_unused() 354 355Issues warning about any variables that were set, but not used. 356 357=cut 358 359sub warn_about_unused { 360 my ($self, %opts) = @_; 361 $opts{msg_prefix} //= $self->{msg_prefix}; 362 363 foreach my $vn (sort keys %{$self->{vars}}) { 364 next if $self->{attr}{$vn} & SUBSTVAR_ATTR_USED; 365 # Empty substitutions variables are ignored on the basis 366 # that they are not required in the current situation 367 # (example: debhelper's misc:Depends in many cases) 368 next if $self->{vars}{$vn} eq ''; 369 warning($opts{msg_prefix} . 370 g_('substitution variable ${%s} unused, but is defined'), 371 $vn); 372 } 373} 374 375=item $s->set_msg_prefix($prefix) 376 377Define a prefix displayed before all warnings/error messages output 378by the module. 379 380=cut 381 382sub set_msg_prefix { 383 my ($self, $prefix) = @_; 384 $self->{msg_prefix} = $prefix; 385} 386 387=item $s->filter(remove => $rmfunc) 388 389=item $s->filter(keep => $keepfun) 390 391Filter the substitution variables, either removing or keeping all those 392that return true when $rmfunc->($key) or $keepfunc->($key) is called. 393 394=cut 395 396sub filter { 397 my ($self, %opts) = @_; 398 399 my $remove = $opts{remove} // sub { 0 }; 400 my $keep = $opts{keep} // sub { 1 }; 401 402 foreach my $vn (keys %{$self->{vars}}) { 403 $self->delete($vn) if $remove->($vn) or not $keep->($vn); 404 } 405} 406 407=item "$s" 408 409Return a string representation of all substitutions variables except the 410automatic ones. 411 412=item $str = $s->output([$fh]) 413 414Return all substitutions variables except the automatic ones. If $fh 415is passed print them into the filehandle. 416 417=cut 418 419sub output { 420 my ($self, $fh) = @_; 421 my $str = ''; 422 # Store all non-automatic substitutions only 423 foreach my $vn (sort keys %{$self->{vars}}) { 424 next if $self->{attr}{$vn} & SUBSTVAR_ATTR_AUTO; 425 my $line = "$vn=" . $self->{vars}{$vn} . "\n"; 426 print { $fh } $line if defined $fh; 427 $str .= $line; 428 } 429 return $str; 430} 431 432=item $s->save($file) 433 434Store all substitutions variables except the automatic ones in the 435indicated file. 436 437=back 438 439=head1 CHANGES 440 441=head2 Version 1.06 (dpkg 1.19.0) 442 443New method: $s->set_desc_substvars(). 444 445=head2 Version 1.05 (dpkg 1.18.11) 446 447Obsolete substvar: Emit an error on Source-Version substvar usage. 448 449New return: $s->parse() now returns the number of parsed substvars. 450 451New method: $s->set_field_substvars(). 452 453=head2 Version 1.04 (dpkg 1.18.0) 454 455New method: $s->filter(). 456 457=head2 Version 1.03 (dpkg 1.17.11) 458 459New method: $s->set_as_auto(). 460 461=head2 Version 1.02 (dpkg 1.16.5) 462 463New argument: Accept a $binaryversion in $s->set_version_substvars(), 464passing a single argument is still supported. 465 466New method: $s->mark_as_used(). 467 468Deprecated method: $s->no_warn(), use $s->mark_as_used() instead. 469 470=head2 Version 1.01 (dpkg 1.16.4) 471 472New method: $s->set_as_used(). 473 474=head2 Version 1.00 (dpkg 1.15.6) 475 476Mark the module as public. 477 478=cut 479 4801; 481