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