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 22use strict; 23use warnings; 24 25use List::Util qw(any all none); 26use Encode; 27use POSIX qw(:errno_h :locale_h); 28 29use Dpkg (); 30use Dpkg::Gettext; 31use Dpkg::File; 32use Dpkg::Checksums; 33use Dpkg::ErrorHandling; 34use Dpkg::Build::Types; 35use Dpkg::BuildProfiles qw(get_build_profiles parse_build_profiles 36 evaluate_restriction_formula); 37use Dpkg::Arch qw(get_host_arch debarch_eq debarch_is debarch_list_parse); 38use Dpkg::Compression; 39use Dpkg::Control::Info; 40use Dpkg::Control::Fields; 41use Dpkg::Control; 42use Dpkg::Substvars; 43use Dpkg::Vars; 44use Dpkg::Changelog::Parse; 45use Dpkg::Dist::Files; 46use Dpkg::Version; 47 48textdomain('dpkg-dev'); 49 50my $controlfile = 'debian/control'; 51my $changelogfile = 'debian/changelog'; 52my $changelogformat; 53my $fileslistfile = 'debian/files'; 54my $outputfile; 55my $uploadfilesdir = '..'; 56my $sourcestyle = 'i'; 57my $quiet = 0; 58my $host_arch = get_host_arch(); 59my @profiles = get_build_profiles(); 60my $changes_format = '1.8'; 61 62my %p2f; # - package to file map, has entries for "packagename" 63my %f2seccf; # - package to section map, from control file 64my %f2pricf; # - package to priority map, from control file 65my %sourcedefault; # - default values as taken from source (used for Section, 66 # Priority and Maintainer) 67 68my @descriptions; 69 70my $checksums = Dpkg::Checksums->new(); 71my %remove; # - fields to remove 72my %override; 73my %archadded; 74my @archvalues; 75my $changesdescription; 76my $forcemaint; 77my $forcechangedby; 78my $since; 79 80my $substvars_loaded = 0; 81my $substvars = Dpkg::Substvars->new(); 82$substvars->set_as_auto('Format', $changes_format); 83 84sub version { 85 printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION; 86 87 printf g_(' 88This is free software; see the GNU General Public License version 2 or 89later for copying conditions. There is NO warranty. 90'); 91} 92 93sub 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 130while (@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. 191if (not defined $outputfile) { 192 report_options(info_fh => \*STDERR, quiet_warnings => $quiet); 193 $outputfile = '-'; 194} 195 196# Retrieve info from the current changelog entry 197my %options = (file => $changelogfile); 198$options{changelogformat} = $changelogformat if $changelogformat; 199$options{since} = $since if defined($since); 200my $changelog = changelog_parse(%options); 201# Change options to retrieve info of the former changelog entry 202delete $options{since}; 203$options{count} = 1; 204$options{offset} = 1; 205my $prev_changelog = changelog_parse(%options); 206# Other initializations 207my $control = Dpkg::Control::Info->new($controlfile); 208my $fields = Dpkg::Control->new(type => CTRL_FILE_CHANGES); 209 210my $sourceversion = $changelog->{'Binary-Only'} ? 211 $prev_changelog->{'Version'} : $changelog->{'Version'}; 212my $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 218if (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 229my $src_fields = $control->get_source(); 230foreach (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 } elsif (m/^Description$/i) { 237 # Description in changes is computed, do not copy this field, only 238 # initialize the description substvars. 239 $substvars->set_desc_substvars($v); 240 } else { 241 field_transfer_single($src_fields, $fields); 242 } 243} 244 245my $dist = Dpkg::Dist::Files->new(); 246my $origsrcmsg; 247 248if (build_has_any(BUILD_SOURCE)) { 249 my $sec = $sourcedefault{'Section'} // '-'; 250 my $pri = $sourcedefault{'Priority'} // '-'; 251 warning(g_('missing Section for source files')) if $sec eq '-'; 252 warning(g_('missing Priority for source files')) if $pri eq '-'; 253 254 my $spackage = get_source_package(); 255 (my $sversion = $substvars->get('source:Version')) =~ s/^\d+://; 256 257 my $dsc = "${spackage}_${sversion}.dsc"; 258 my $dsc_pathname = "$uploadfilesdir/$dsc"; 259 my $dsc_fields = Dpkg::Control->new(type => CTRL_PKG_SRC); 260 $dsc_fields->load($dsc_pathname) or error(g_('%s is empty'), $dsc_pathname); 261 $checksums->add_from_file($dsc_pathname, key => $dsc); 262 $checksums->add_from_control($dsc_fields, use_files_for_md5 => 1); 263 264 # Compare upstream version to previous upstream version to decide if 265 # the .orig tarballs must be included 266 my $include_tarball; 267 if (defined($prev_changelog)) { 268 my $cur = Dpkg::Version->new($changelog->{'Version'}); 269 my $prev = Dpkg::Version->new($prev_changelog->{'Version'}); 270 $include_tarball = ($cur->version() ne $prev->version()) ? 1 : 0; 271 } else { 272 # No previous entry means first upload, tarball required 273 $include_tarball = 1; 274 } 275 276 my $ext = compression_get_file_extension_regex(); 277 if ((($sourcestyle =~ m/i/ && !$include_tarball) || 278 $sourcestyle =~ m/d/) && 279 any { m/\.(?:debian\.tar|diff)\.$ext$/ } $checksums->get_files()) 280 { 281 $origsrcmsg = g_('not including original source code in upload'); 282 foreach my $f (grep { m/\.orig(-.+)?\.tar\.$ext$/ } $checksums->get_files()) { 283 $checksums->remove_file($f); 284 $checksums->remove_file("$f.asc"); 285 } 286 } else { 287 if ($sourcestyle =~ m/d/ && 288 none { m/\.(?:debian\.tar|diff)\.$ext$/ } $checksums->get_files()) { 289 warning(g_('ignoring -sd option for native Debian package')); 290 } 291 $origsrcmsg = g_('including full source code in upload'); 292 } 293 294 push @archvalues, 'source'; 295 296 # Only add attributes for files being distributed. 297 for my $f ($checksums->get_files()) { 298 $dist->add_file($f, $sec, $pri); 299 } 300} elsif (build_is(BUILD_ARCH_DEP)) { 301 $origsrcmsg = g_('binary-only arch-specific upload ' . 302 '(source code and arch-indep packages not included)'); 303} elsif (build_is(BUILD_ARCH_INDEP)) { 304 $origsrcmsg = g_('binary-only arch-indep upload ' . 305 '(source code and arch-specific packages not included)'); 306} else { 307 $origsrcmsg = g_('binary-only upload (no source code included)'); 308} 309 310my $dist_binaries = 0; 311 312$dist->load($fileslistfile) if -e $fileslistfile; 313 314foreach my $file ($dist->get_files()) { 315 my $f = $file->{filename}; 316 317 if (defined $file->{package} && $file->{package_type} eq 'buildinfo') { 318 # We always distribute the .buildinfo file. 319 $checksums->add_from_file("$uploadfilesdir/$f", key => $f); 320 next; 321 } 322 323 # If this is a source-only upload, ignore any other artifacts. 324 next if build_has_none(BUILD_BINARY); 325 326 if (defined $file->{arch}) { 327 my $arch_all = debarch_eq('all', $file->{arch}); 328 329 next if build_has_none(BUILD_ARCH_INDEP) and $arch_all; 330 next if build_has_none(BUILD_ARCH_DEP) and not $arch_all; 331 332 push @archvalues, $file->{arch} if not $archadded{$file->{arch}}++; 333 } 334 if (defined $file->{package} && $file->{package_type} =~ m/^u?deb$/) { 335 $p2f{$file->{package}} //= []; 336 push @{$p2f{$file->{package}}}, $file->{filename}; 337 } 338 339 $checksums->add_from_file("$uploadfilesdir/$f", key => $f); 340 $dist_binaries++; 341} 342 343error(g_('binary build with no binary artifacts found; cannot distribute')) 344 if build_has_any(BUILD_BINARY) && $dist_binaries == 0; 345 346# Scan control info of all binary packages 347foreach my $pkg ($control->get_packages()) { 348 my $p = $pkg->{'Package'}; 349 my $a = $pkg->{'Architecture'}; 350 my $bp = $pkg->{'Build-Profiles'}; 351 my $d = $pkg->{'Description'} || 'no description available'; 352 $d = $1 if $d =~ /^(.*)\n/; 353 my $pkg_type = $pkg->{'Package-Type'} || 354 $pkg->get_custom_field('Package-Type') || 'deb'; 355 356 my @restrictions; 357 @restrictions = parse_build_profiles($bp) if defined $bp; 358 359 if (not defined($p2f{$p})) { 360 # No files for this package... warn if it's unexpected 361 if (((build_has_any(BUILD_ARCH_INDEP) and debarch_eq('all', $a)) or 362 (build_has_any(BUILD_ARCH_DEP) and 363 (any { debarch_is($host_arch, $_) } debarch_list_parse($a, positive => 1)))) and 364 (@restrictions == 0 or 365 evaluate_restriction_formula(\@restrictions, \@profiles))) 366 { 367 warning(g_('package %s in control file but not in files list'), 368 $p); 369 } 370 next; # and skip it 371 } 372 373 # Add description of all binary packages 374 $d = $substvars->substvars($d); 375 my $desc = encode_utf8(sprintf('%-10s - %-.65s', $p, decode_utf8($d))); 376 $desc .= " ($pkg_type)" if $pkg_type ne 'deb'; 377 push @descriptions, $desc; 378 379 # List of files for this binary package. 380 my @f = @{$p2f{$p}}; 381 382 foreach (keys %{$pkg}) { 383 my $v = $pkg->{$_}; 384 385 if (m/^Section$/) { 386 $f2seccf{$_} = $v foreach (@f); 387 } elsif (m/^Priority$/) { 388 $f2pricf{$_} = $v foreach (@f); 389 } elsif (m/^Architecture$/) { 390 if (build_has_any(BUILD_ARCH_DEP) and 391 (any { debarch_is($host_arch, $_) } debarch_list_parse($v, positive => 1))) { 392 $v = $host_arch; 393 } elsif (!debarch_eq('all', $v)) { 394 $v = ''; 395 } 396 push(@archvalues, $v) if $v and not $archadded{$v}++; 397 } elsif (m/^Description$/) { 398 # Description in changes is computed, do not copy this field 399 } else { 400 field_transfer_single($pkg, $fields); 401 } 402 } 403} 404 405# Scan fields of dpkg-parsechangelog 406foreach (keys %{$changelog}) { 407 my $v = $changelog->{$_}; 408 if (m/^Source$/i) { 409 set_source_package($v); 410 } elsif (m/^Maintainer$/i) { 411 $fields->{'Changed-By'} = $v; 412 } else { 413 field_transfer_single($changelog, $fields); 414 } 415} 416 417if ($changesdescription) { 418 $fields->{'Changes'} = "\n" . file_slurp($changesdescription); 419} 420 421for my $p (keys %p2f) { 422 if (not defined $control->get_pkg_by_name($p)) { 423 # Skip automatically generated packages (such as debugging symbol 424 # packages), by using the Auto-Built-Package field. 425 next if all { 426 my $file = $dist->get_file($_); 427 428 $file->{attrs}->{automatic} eq 'yes' 429 } @{$p2f{$p}}; 430 431 warning(g_('package %s listed in files list but not in control info'), $p); 432 next; 433 } 434 435 foreach my $f (@{$p2f{$p}}) { 436 my $file = $dist->get_file($f); 437 438 my $sec = $f2seccf{$f} || $sourcedefault{'Section'} // '-'; 439 if ($sec eq '-') { 440 warning(g_("missing Section for binary package %s; using '-'"), $p); 441 } 442 if ($sec ne $file->{section}) { 443 error(g_('package %s has section %s in control file but %s in ' . 444 'files list'), $p, $sec, $file->{section}); 445 } 446 447 my $pri = $f2pricf{$f} || $sourcedefault{'Priority'} // '-'; 448 if ($pri eq '-') { 449 warning(g_("missing Priority for binary package %s; using '-'"), $p); 450 } 451 if ($pri ne $file->{priority}) { 452 error(g_('package %s has priority %s in control file but %s in ' . 453 'files list'), $p, $pri, $file->{priority}); 454 } 455 } 456} 457 458info($origsrcmsg); 459 460$fields->{'Format'} = $substvars->get('Format'); 461 462if (!defined($fields->{'Date'})) { 463 setlocale(LC_TIME, 'C'); 464 $fields->{'Date'} = POSIX::strftime('%a, %d %b %Y %T %z', localtime); 465 setlocale(LC_TIME, ''); 466} 467 468$fields->{'Binary'} = join ' ', sort keys %p2f; 469# Avoid overly long line by splitting over multiple lines 470if (length($fields->{'Binary'}) > 980) { 471 $fields->{'Binary'} =~ s/(.{0,980}) /$1\n/g; 472} 473 474$fields->{'Architecture'} = join ' ', @archvalues; 475 476$fields->{'Built-For-Profiles'} = join ' ', get_build_profiles(); 477 478$fields->{'Description'} = "\n" . join("\n", sort @descriptions); 479 480$fields->{'Files'} = ''; 481 482foreach my $f ($checksums->get_files()) { 483 my $file = $dist->get_file($f); 484 485 $fields->{'Files'} .= "\n" . $checksums->get_checksum($f, 'md5') . 486 ' ' . $checksums->get_size($f) . 487 " $file->{section} $file->{priority} $f"; 488} 489$checksums->export_to_control($fields); 490# redundant with the Files field 491delete $fields->{'Checksums-Md5'}; 492 493$fields->{'Source'} = get_source_package(); 494if ($fields->{'Version'} ne $substvars->get('source:Version')) { 495 $fields->{'Source'} .= ' (' . $substvars->get('source:Version') . ')'; 496} 497 498$fields->{'Maintainer'} = $forcemaint if defined($forcemaint); 499$fields->{'Changed-By'} = $forcechangedby if defined($forcechangedby); 500 501for my $f (qw(Version Distribution Maintainer Changes)) { 502 error(g_('missing information for critical output field %s'), $f) 503 unless defined $fields->{$f}; 504} 505 506for my $f (qw(Urgency)) { 507 warning(g_('missing information for output field %s'), $f) 508 unless defined $fields->{$f}; 509} 510 511for my $f (keys %override) { 512 $fields->{$f} = $override{$f}; 513} 514for my $f (keys %remove) { 515 delete $fields->{$f}; 516} 517 518# Note: do not perform substitution of variables, one of the reasons is that 519# they could interfere with field values, for example the Changes field. 520$fields->save($outputfile); 521