scripts/dpkg-genchanges.pl

   1 #!/usr/bin/perl
   2 #
   3 # dpkg-genchanges
   4 #
   5 # Copyright © 1996 Ian Jackson
   6 # Copyright © 2000,2001 Wichert Akkerman
   7 # Copyright © 2006-2014 Guillem Jover <guillem@debian.org>
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 2 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  21
  22 use strict;
  23 use warnings;
  24
  25 use List::Util qw(any all none);
  26 use POSIX qw(:errno_h :locale_h);
  27
  28 use Dpkg ();
  29 use Dpkg::Gettext;
  30 use Dpkg::File;
  31 use Dpkg::Checksums;
  32 use Dpkg::ErrorHandling;
  33 use Dpkg::BuildTypes;
  34 use Dpkg::BuildProfiles qw(get_build_profiles parse_build_profiles
  35                            evaluate_restriction_formula);
  36 use Dpkg::Arch qw(get_host_arch debarch_eq debarch_is debarch_list_parse);
  37 use Dpkg::Compression;
  38 use Dpkg::Control::Info;
  39 use Dpkg::Control::Fields;
  40 use Dpkg::Control;
  41 use Dpkg::Substvars;
  42 use Dpkg::Package;
  43 use Dpkg::Changelog::Parse;
  44 use Dpkg::Dist::Files;
  45 use Dpkg::Version;
  46 use Dpkg::Vendor qw(run_vendor_hook);
  47
  48 textdomain('dpkg-dev');
  49
  50 my $controlfile = 'debian/control';
  51 my $changelogfile = 'debian/changelog';
  52 my $changelogformat;
  53 my $fileslistfile = 'debian/files';
  54 my $outputfile;
  55 my $uploadfilesdir = '..';
  56 my $sourcestyle = 'i';
  57 my $quiet = 0;
  58 my $host_arch = get_host_arch();
  59 my @profiles = get_build_profiles();
  60 my $changes_format = '1.8';
  61
  62 # Package to file map, has entries for "packagename".
  63 my %pkg2file;
  64 # Package to section map, from control file.
  65 my %file2ctrlsec;
  66 # Package to priority map, from control file.
  67 my %file2ctrlpri;
  68 # Default values taken from source (used for Section, Priority and Maintainer).
  69 my %sourcedefault;
  70
  71 my @descriptions;
  72
  73 my $checksums = Dpkg::Checksums->new();
  74 my %remove;        # - fields to remove
  75 my %override;
  76 my %archadded;
  77 my @archvalues;
  78 my $changesdescription;
  79 my $forcemaint;
  80 my $forcechangedby;
  81 my $since;
  82
  83 my $substvars_loaded = 0;
  84 my $substvars = Dpkg::Substvars->new();
  85 $substvars->set_as_auto('Format', $changes_format);
  86
  87 sub version {
  88     printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
  89
  90     printf g_('
  91 This is free software; see the GNU General Public License version 2 or
  92 later for copying conditions. There is NO warranty.
  93 ');
  94 }
  95
  96 sub usage {
  97     printf g_(
  98 'Usage: %s [<option>...]')
  99     . "\n\n" . g_(
 100 "Options:
 101   --build=<type>[,...]     specify the build <type>: full, source, binary,
 102                              any, all (default is \'full\').
 103   -g                       source and arch-indep build.
 104   -G                       source and arch-specific build.
 105   -b                       binary-only, no source files.
 106   -B                       binary-only, only arch-specific files.
 107   -A                       binary-only, only arch-indep files.
 108   -S                       source-only, no binary files.
 109   -c<control-file>         get control info from this file.
 110   -l<changelog-file>       get per-version info from this file.
 111   -f<files-list-file>      get .deb files list from this file.
 112   -v<since-version>        include all changes later than version.
 113   -C<changes-description>  use change description from this file.
 114   -m<maintainer>           override control's maintainer value.
 115   -e<maintainer>           override changelog's maintainer value.
 116   -u<upload-files-dir>     directory with files (default is '..').
 117   -si                      source includes orig, if new upstream (default).
 118   -sa                      source includes orig, always.
 119   -sd                      source is diff and .dsc only.
 120   -q                       quiet - no informational messages on stderr.
 121   -F<changelog-format>     force changelog format.
 122   -V<name>=<value>         set a substitution variable.
 123   -T<substvars-file>       read variables here, not debian/substvars.
 124   -D<field>=<value>        override or add a field and value.
 125   -U<field>                remove a field.
 126   -O[<filename>]           write to stdout (default) or <filename>.
 127   -?, --help               show this help message.
 128       --version            show the version.
 129 "), $Dpkg::PROGNAME;
 130 }
 131
 132 sub format_desc
 133 {
 134     my ($pkgname, $pkgtype, $desc) = @_;
 135
 136     # XXX: This does not correctly truncate characters based on their width,
 137     # but on the number of characters which will not work for wide ones. But
 138     # we do not have anything better in perl core.
 139     utf8::decode($desc);
 140     my $line = sprintf '%-10s - %-.65s', $pkgname, $desc;
 141     utf8::encode($line);
 142
 143     $line .= " ($pkgtype)" if $pkgtype ne 'deb';
 144
 145     return $line;
 146 }
 147
 148
 149 while (@ARGV) {
 150     $_ = shift @ARGV;
 151     if (m/^--build=(.*)$/) {
 152         set_build_type_from_options($1, $_);
 153     } elsif (m/^-b$/) {
 154         set_build_type(BUILD_BINARY, $_);
 155     } elsif (m/^-B$/) {
 156         set_build_type(BUILD_ARCH_DEP, $_);
 157     } elsif (m/^-A$/) {
 158         set_build_type(BUILD_ARCH_INDEP, $_);
 159     } elsif (m/^-S$/) {
 160         set_build_type(BUILD_SOURCE, $_);
 161     } elsif (m/^-G$/) {
 162         set_build_type(BUILD_SOURCE | BUILD_ARCH_DEP, $_);
 163     } elsif (m/^-g$/) {
 164         set_build_type(BUILD_SOURCE | BUILD_ARCH_INDEP, $_);
 165     } elsif (m/^-s([iad])$/) {
 166         $sourcestyle = $1;
 167     } elsif (m/^-q$/) {
 168         $quiet = 1;
 169     } elsif (m/^-c(.*)$/) {
 170         $controlfile = $1;
 171     } elsif (m/^-l(.*)$/) {
 172         $changelogfile = $1;
 173     } elsif (m/^-C(.*)$/) {
 174         $changesdescription = $1;
 175     } elsif (m/^-f(.*)$/) {
 176         $fileslistfile = $1;
 177     } elsif (m/^-v(.*)$/) {
 178         $since = $1;
 179     } elsif (m/^-T(.*)$/) {
 180         $substvars->load($1) if -e $1;
 181         $substvars_loaded = 1;
 182     } elsif (m/^-m(.*)$/s) {
 183         $forcemaint = $1;
 184     } elsif (m/^-e(.*)$/s) {
 185         $forcechangedby = $1;
 186     } elsif (m/^-F([0-9a-z]+)$/) {
 187         $changelogformat = $1;
 188     } elsif (m/^-D([^\=:]+)[=:](.*)$/s) {
 189         $override{$1} = $2;
 190     } elsif (m/^-u(.*)$/) {
 191         $uploadfilesdir = $1;
 192     } elsif (m/^-U([^\=:]+)$/) {
 193         $remove{$1} = 1;
 194     } elsif (m/^-V(\w[-:0-9A-Za-z]*)[=:](.*)$/s) {
 195         $substvars->set($1, $2);
 196     } elsif (m/^-O(.*)$/) {
 197         $outputfile = $1;
 198     } elsif (m/^-(?:\?|-help)$/) {
 199         usage();
 200         exit(0);
 201     } elsif (m/^--version$/) {
 202         version();
 203         exit(0);
 204     } else {
 205         usageerr(g_("unknown option '%s'"), $_);
 206     }
 207 }
 208
 209 # Do not pollute STDOUT with info messages if the .changes file goes there.
 210 if (not defined $outputfile) {
 211     report_options(info_fh => \*STDERR, quiet_warnings => $quiet);
 212     $outputfile = '-';
 213 }
 214
 215 # Retrieve info from the current changelog entry
 216 my %options = (file => $changelogfile);
 217 $options{changelogformat} = $changelogformat if $changelogformat;
 218 $options{since} = $since if defined($since);
 219 my $changelog = changelog_parse(%options);
 220 # Change options to retrieve info of the former changelog entry
 221 delete $options{since};
 222 $options{count} = 1;
 223 $options{offset} = 1;
 224 my $prev_changelog = changelog_parse(%options);
 225 # Other initializations
 226 my $control = Dpkg::Control::Info->new($controlfile);
 227 my $fields = Dpkg::Control->new(type => CTRL_FILE_CHANGES);
 228
 229 my $sourceversion = $changelog->{'Binary-Only'} ?
 230                     $prev_changelog->{'Version'} : $changelog->{'Version'};
 231 my $binaryversion = $changelog->{'Version'};
 232
 233 $substvars->set_version_substvars($sourceversion, $binaryversion);
 234 $substvars->set_vendor_substvars();
 235 $substvars->set_arch_substvars();
 236 $substvars->load('debian/substvars') if -e 'debian/substvars' and not $substvars_loaded;
 237
 238 my $backport_version_regex = run_vendor_hook('backport-version-regex') // qr/^$/;
 239 my $is_backport = $changelog->{'Version'} =~ m/$backport_version_regex/;
 240
 241 # Versions with backport markers have a lower version number by definition.
 242 if (! $is_backport && defined $prev_changelog &&
 243     version_compare_relation($changelog->{'Version'}, REL_LT,
 244                              $prev_changelog->{'Version'}))
 245 {
 246     warning(g_('the current version (%s) is earlier than the previous one (%s)'),
 247             $changelog->{'Version'}, $prev_changelog->{'Version'});
 248 }
 249
 250 # Scan control info of source package
 251 my $src_fields = $control->get_source();
 252 foreach my $f (keys %{$src_fields}) {
 253     my $v = $src_fields->{$f};
 254     if ($f eq 'Source') {
 255         set_source_name($v);
 256     } elsif (any { $f eq $_ } qw(Section Priority)) {
 257         $sourcedefault{$f} = $v;
 258     } elsif ($f eq 'Description') {
 259         # Description in changes is computed, do not copy this field, only
 260         # initialize the description substvars.
 261         $substvars->set_desc_substvars($v);
 262     } else {
 263         field_transfer_single($src_fields, $fields, $f);
 264     }
 265 }
 266
 267 my $dist = Dpkg::Dist::Files->new();
 268 my $origsrcmsg;
 269
 270 if (build_has_any(BUILD_SOURCE)) {
 271     my $sec = $sourcedefault{'Section'} // '-';
 272     my $pri = $sourcedefault{'Priority'} // '-';
 273     warning(g_('missing Section for source files')) if $sec eq '-';
 274     warning(g_('missing Priority for source files')) if $pri eq '-';
 275
 276     my $spackage = get_source_name();
 277     (my $sversion = $substvars->get('source:Version')) =~ s/^\d+://;
 278
 279     my $dsc = "${spackage}_${sversion}.dsc";
 280     my $dsc_pathname = "$uploadfilesdir/$dsc";
 281     my $dsc_fields = Dpkg::Control->new(type => CTRL_PKG_SRC);
 282     $dsc_fields->load($dsc_pathname) or error(g_('%s is empty'), $dsc_pathname);
 283     $checksums->add_from_file($dsc_pathname, key => $dsc);
 284     $checksums->add_from_control($dsc_fields, use_files_for_md5 => 1);
 285
 286     # Compare upstream version to previous upstream version to decide if
 287     # the .orig tarballs must be included
 288     my $include_tarball;
 289     if (defined($prev_changelog)) {
 290         my $cur = Dpkg::Version->new($changelog->{'Version'});
 291         my $prev = Dpkg::Version->new($prev_changelog->{'Version'});
 292         if ($cur->version() ne $prev->version()) {
 293             $include_tarball = 1;
 294         } elsif ($changelog->{'Source'} ne $prev_changelog->{'Source'}) {
 295             $include_tarball = 1;
 296         } else {
 297             $include_tarball = 0;
 298         }
 299     } else {
 300         # No previous entry means first upload, tarball required
 301         $include_tarball = 1;
 302     }
 303
 304     my $ext = compression_get_file_extension_regex();
 305     if ((($sourcestyle =~ m/i/ && !$include_tarball) ||
 306          $sourcestyle =~ m/d/) &&
 307         any { m/\.(?:debian\.tar|diff)\.$ext$/ } $checksums->get_files())
 308     {
 309         $origsrcmsg = g_('not including original source code in upload');
 310         foreach my $fn (grep { m/\.orig(-.+)?\.tar\.$ext$/ } $checksums->get_files()) {
 311             $checksums->remove_file($fn);
 312             $checksums->remove_file("$fn.asc");
 313         }
 314     } else {
 315         if ($sourcestyle =~ m/d/ &&
 316             none { m/\.(?:debian\.tar|diff)\.$ext$/ } $checksums->get_files()) {
 317             warning(g_('ignoring -sd option for native Debian package'));
 318         }
 319         $origsrcmsg = g_('including full source code in upload');
 320     }
 321
 322     push @archvalues, 'source';
 323
 324     # Only add attributes for files being distributed.
 325     for my $fn ($checksums->get_files()) {
 326         $dist->add_file($fn, $sec, $pri);
 327     }
 328 } elsif (build_is(BUILD_ARCH_DEP)) {
 329     $origsrcmsg = g_('binary-only arch-specific upload ' .
 330                      '(source code and arch-indep packages not included)');
 331 } elsif (build_is(BUILD_ARCH_INDEP)) {
 332     $origsrcmsg = g_('binary-only arch-indep upload ' .
 333                      '(source code and arch-specific packages not included)');
 334 } else {
 335     $origsrcmsg = g_('binary-only upload (no source code included)');
 336 }
 337
 338 my $dist_binaries = 0;
 339
 340 $dist->load($fileslistfile) if -e $fileslistfile;
 341
 342 foreach my $file ($dist->get_files()) {
 343     my $fn = $file->{filename};
 344     my $p = $file->{package};
 345     my $a = $file->{arch};
 346
 347     if (defined $p && $file->{package_type} eq 'buildinfo') {
 348         # We always distribute the .buildinfo file.
 349         $checksums->add_from_file("$uploadfilesdir/$fn", key => $fn);
 350         next;
 351     }
 352
 353     # If this is a source-only upload, ignore any other artifacts.
 354     next if build_has_none(BUILD_BINARY);
 355
 356     if (defined $a) {
 357         my $arch_all = debarch_eq('all', $a);
 358
 359         next if build_has_none(BUILD_ARCH_INDEP) and $arch_all;
 360         next if build_has_none(BUILD_ARCH_DEP) and not $arch_all;
 361
 362         push @archvalues, $a if not $archadded{$a}++;
 363     }
 364     if (defined $p && $file->{package_type} =~ m/^u?deb$/) {
 365         $pkg2file{$p} //= [];
 366         push @{$pkg2file{$p}}, $fn;
 367     }
 368
 369     $checksums->add_from_file("$uploadfilesdir/$fn", key => $fn);
 370     $dist_binaries++;
 371 }
 372
 373 error(g_('binary build with no binary artifacts found; cannot distribute'))
 374     if build_has_any(BUILD_BINARY) && $dist_binaries == 0;
 375
 376 # Scan control info of all binary packages
 377 foreach my $pkg ($control->get_packages()) {
 378     my $p = $pkg->{'Package'};
 379     my $a = $pkg->{'Architecture'};
 380     my $bp = $pkg->{'Build-Profiles'};
 381     my $d = $pkg->{'Description'} || 'no description available';
 382     $d = $1 if $d =~ /^(.*)\n/;
 383     my $pkg_type = $pkg->{'Package-Type'} ||
 384                    $pkg->get_custom_field('Package-Type') || 'deb';
 385
 386     my @restrictions;
 387     @restrictions = parse_build_profiles($bp) if defined $bp;
 388
 389     if (not defined $pkg2file{$p}) {
 390         # No files for this package... warn if it's unexpected
 391         if (((build_has_any(BUILD_ARCH_INDEP) and debarch_eq('all', $a)) or
 392              (build_has_any(BUILD_ARCH_DEP) and
 393               (any { debarch_is($host_arch, $_) } debarch_list_parse($a, positive => 1)))) and
 394             (@restrictions == 0 or
 395              evaluate_restriction_formula(\@restrictions, \@profiles)))
 396         {
 397             warning(g_('package %s in control file but not in files list'),
 398                     $p);
 399         }
 400         next; # and skip it
 401     }
 402
 403     # Add description of all binary packages
 404     $d = $substvars->substvars($d);
 405     push @descriptions, format_desc($p, $pkg_type, $d);
 406
 407     # List of files for this binary package.
 408     my @files = @{$pkg2file{$p}};
 409
 410     foreach my $f (keys %{$pkg}) {
 411         my $v = $pkg->{$f};
 412
 413         if ($f eq 'Section') {
 414             $file2ctrlsec{$_} = $v foreach @files;
 415         } elsif ($f eq 'Priority') {
 416             $file2ctrlpri{$_} = $v foreach @files;
 417         } elsif ($f eq 'Architecture') {
 418             if (build_has_any(BUILD_ARCH_DEP) and
 419                 (any { debarch_is($host_arch, $_) } debarch_list_parse($v, positive => 1))) {
 420                 $v = $host_arch;
 421             } elsif (!debarch_eq('all', $v)) {
 422                 $v = '';
 423             }
 424             push(@archvalues, $v) if $v and not $archadded{$v}++;
 425         } elsif ($f eq 'Description') {
 426             # Description in changes is computed, do not copy this field
 427         } else {
 428             field_transfer_single($pkg, $fields, $f);
 429         }
 430     }
 431 }
 432
 433 # Scan fields of dpkg-parsechangelog
 434 foreach my $f (keys %{$changelog}) {
 435     my $v = $changelog->{$f};
 436     if ($f eq 'Source') {
 437         set_source_name($v);
 438     } elsif ($f eq 'Maintainer') {
 439         $fields->{'Changed-By'} = $v;
 440     } else {
 441         field_transfer_single($changelog, $fields, $f);
 442     }
 443 }
 444
 445 if ($changesdescription) {
 446     $fields->{'Changes'} = "\n" . file_slurp($changesdescription);
 447 }
 448
 449 for my $p (keys %pkg2file) {
 450     if (not defined $control->get_pkg_by_name($p)) {
 451         # Skip automatically generated packages (such as debugging symbol
 452         # packages), by using the Auto-Built-Package field.
 453         next if all {
 454             my $file = $dist->get_file($_);
 455
 456             $file->{attrs}->{automatic} eq 'yes'
 457         } @{$pkg2file{$p}};
 458
 459         warning(g_('package %s listed in files list but not in control info'), $p);
 460         next;
 461     }
 462
 463     foreach my $fn (@{$pkg2file{$p}}) {
 464         my $file = $dist->get_file($fn);
 465
 466         my $sec = $file2ctrlsec{$fn} || $sourcedefault{'Section'} // '-';
 467         if ($sec eq '-') {
 468             warning(g_("missing Section for binary package %s; using '-'"), $p);
 469         }
 470         if ($sec ne $file->{section}) {
 471             error(g_('package %s has section %s in control file but %s in ' .
 472                      'files list'), $p, $sec, $file->{section});
 473         }
 474
 475         my $pri = $file2ctrlpri{$fn} || $sourcedefault{'Priority'} // '-';
 476         if ($pri eq '-') {
 477             warning(g_("missing Priority for binary package %s; using '-'"), $p);
 478         }
 479         if ($pri ne $file->{priority}) {
 480             error(g_('package %s has priority %s in control file but %s in ' .
 481                      'files list'), $p, $pri, $file->{priority});
 482         }
 483     }
 484 }
 485
 486 info($origsrcmsg);
 487
 488 $fields->{'Format'} = $substvars->get('Format');
 489
 490 if (length $fields->{'Date'} == 0) {
 491     setlocale(LC_TIME, 'C');
 492     $fields->{'Date'} = POSIX::strftime('%a, %d %b %Y %T %z', localtime);
 493     setlocale(LC_TIME, '');
 494 }
 495
 496 $fields->{'Binary'} = join ' ', sort keys %pkg2file;
 497 # Avoid overly long line by splitting over multiple lines
 498 if (length($fields->{'Binary'}) > 980) {
 499     $fields->{'Binary'} =~ s/(.{0,980}) /$1\n/g;
 500 }
 501
 502 $fields->{'Architecture'} = join ' ', @archvalues;
 503
 504 $fields->{'Built-For-Profiles'} = join ' ', get_build_profiles();
 505
 506 $fields->{'Description'} = "\n" . join("\n", sort @descriptions);
 507
 508 $fields->{'Files'} = '';
 509
 510 foreach my $fn ($checksums->get_files()) {
 511     my $file = $dist->get_file($fn);
 512
 513     $fields->{'Files'} .= "\n" . $checksums->get_checksum($fn, 'md5') .
 514                           ' ' . $checksums->get_size($fn) .
 515                           " $file->{section} $file->{priority} $fn";
 516 }
 517 $checksums->export_to_control($fields);
 518 # redundant with the Files field
 519 delete $fields->{'Checksums-Md5'};
 520
 521 $fields->{'Source'} = get_source_name();
 522 if ($fields->{'Version'} ne $substvars->get('source:Version')) {
 523     $fields->{'Source'} .= ' (' . $substvars->get('source:Version') . ')';
 524 }
 525
 526 $fields->{'Maintainer'} = $forcemaint if defined($forcemaint);
 527 $fields->{'Changed-By'} = $forcechangedby if defined($forcechangedby);
 528
 529 for my $f (qw(Version Distribution Maintainer Changes)) {
 530     error(g_('missing information for critical output field %s'), $f)
 531         unless defined $fields->{$f};
 532 }
 533
 534 for my $f (qw(Urgency)) {
 535     warning(g_('missing information for output field %s'), $f)
 536         unless defined $fields->{$f};
 537 }
 538
 539 for my $f (keys %override) {
 540     $fields->{$f} = $override{$f};
 541 }
 542 for my $f (keys %remove) {
 543     delete $fields->{$f};
 544 }
 545
 546 # Note: do not perform substitution of variables, one of the reasons is that
 547 # they could interfere with field values, for example the Changes field.
 548 $fields->save($outputfile);