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