Commit | Line | Data |
---|---|---|
1479465f GJ |
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); |