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