scripts/Dpkg/Substvars.pm

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