Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | #!/usr/bin/perl |
2 | # | |
3 | # dpkg-genbuildinfo | |
4 | # | |
5 | # Copyright © 1996 Ian Jackson | |
6 | # Copyright © 2000,2001 Wichert Akkerman | |
7 | # Copyright © 2003-2013 Yann Dirson <dirson@debian.org> | |
8 | # Copyright © 2006-2016 Guillem Jover <guillem@debian.org> | |
9 | # Copyright © 2014 Niko Tyni <ntyni@debian.org> | |
10 | # Copyright © 2014-2015 Jérémy Bobbio <lunar@debian.org> | |
11 | # | |
12 | # This program is free software; you can redistribute it and/or modify | |
13 | # it under the terms of the GNU General Public License as published by | |
14 | # the Free Software Foundation; either version 2 of the License, or | |
15 | # (at your option) any later version. | |
16 | # | |
17 | # This program is distributed in the hope that it will be useful, | |
18 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | # GNU General Public License for more details. | |
21 | # | |
22 | # You should have received a copy of the GNU General Public License | |
23 | # along with this program. If not, see <https://www.gnu.org/licenses/>. | |
24 | ||
25 | use strict; | |
26 | use warnings; | |
27 | ||
28 | use Cwd; | |
29 | use File::Basename; | |
30 | use POSIX qw(:fcntl_h :locale_h strftime); | |
31 | ||
32 | use Dpkg (); | |
33 | use Dpkg::Gettext; | |
34 | use Dpkg::Checksums; | |
35 | use Dpkg::ErrorHandling; | |
36 | use Dpkg::Arch qw(get_build_arch get_host_arch debarch_eq); | |
37 | use Dpkg::Build::Types; | |
38 | use Dpkg::Build::Info qw(get_build_env_whitelist); | |
39 | use Dpkg::BuildOptions; | |
40 | use Dpkg::BuildFlags; | |
41 | use Dpkg::BuildProfiles qw(get_build_profiles); | |
42 | use Dpkg::Control::Info; | |
43 | use Dpkg::Control::Fields; | |
44 | use Dpkg::Control; | |
45 | use Dpkg::Changelog::Parse; | |
46 | use Dpkg::Deps; | |
47 | use Dpkg::Dist::Files; | |
48 | use Dpkg::Util qw(:list); | |
49 | use Dpkg::File; | |
50 | use Dpkg::Version; | |
51 | use Dpkg::Vendor qw(get_current_vendor run_vendor_hook); | |
52 | ||
53 | textdomain('dpkg-dev'); | |
54 | ||
55 | my $controlfile = 'debian/control'; | |
56 | my $changelogfile = 'debian/changelog'; | |
57 | my $changelogformat; | |
58 | my $fileslistfile = 'debian/files'; | |
59 | my $uploadfilesdir = '..'; | |
60 | my $outputfile; | |
61 | my $stdout = 0; | |
62 | my $admindir = $Dpkg::ADMINDIR; | |
63 | my %use_feature = ( | |
64 | path => 0, | |
65 | ); | |
66 | my @build_profiles = get_build_profiles(); | |
67 | my $buildinfo_format = '1.0'; | |
68 | my $buildinfo; | |
69 | ||
70 | my $checksums = Dpkg::Checksums->new(); | |
71 | my %archadded; | |
72 | my @archvalues; | |
73 | ||
74 | sub get_build_date { | |
75 | my $date; | |
76 | ||
77 | setlocale(LC_TIME, 'C'); | |
78 | $date = strftime('%a, %d %b %Y %T %z', localtime); | |
79 | setlocale(LC_TIME, ''); | |
80 | ||
81 | return $date; | |
82 | } | |
83 | ||
84 | # There is almost the same function in dpkg-checkbuilddeps, they probably | |
85 | # should be factored out. | |
86 | sub parse_status { | |
87 | my $status = shift; | |
88 | ||
89 | my $facts = Dpkg::Deps::KnownFacts->new(); | |
90 | my %depends; | |
91 | my @essential_pkgs; | |
92 | ||
93 | local $/ = ''; | |
94 | open my $status_fh, '<', $status or syserr(g_('cannot open %s'), $status); | |
95 | while (<$status_fh>) { | |
96 | next unless /^Status: .*ok installed$/m; | |
97 | ||
98 | my ($package) = /^Package: (.*)$/m; | |
99 | my ($version) = /^Version: (.*)$/m; | |
100 | my ($arch) = /^Architecture: (.*)$/m; | |
101 | my ($multiarch) = /^Multi-Arch: (.*)$/m; | |
102 | ||
103 | $facts->add_installed_package($package, $version, $arch, $multiarch); | |
104 | ||
105 | if (/^Essential: yes$/m) { | |
106 | push @essential_pkgs, $package; | |
107 | } | |
108 | ||
109 | if (/^Provides: (.*)$/m) { | |
110 | my $provides = deps_parse($1, reduce_arch => 1, union => 1); | |
111 | ||
112 | next if not defined $provides; | |
113 | ||
114 | deps_iterate($provides, sub { | |
115 | my $dep = shift; | |
116 | $facts->add_provided_package($dep->{package}, $dep->{relation}, | |
117 | $dep->{version}, $package); | |
118 | }); | |
119 | } | |
120 | ||
121 | foreach my $deptype (qw(Pre-Depends Depends)) { | |
122 | next unless /^$deptype: (.*)$/m; | |
123 | ||
124 | my $depends = $1; | |
125 | foreach (split /,\s*/, $depends) { | |
126 | push @{$depends{"$package:$arch"}}, $_; | |
127 | } | |
128 | } | |
129 | } | |
130 | close $status_fh; | |
131 | ||
132 | return ($facts, \%depends, \@essential_pkgs); | |
133 | } | |
134 | ||
135 | sub append_deps { | |
136 | my $pkgs = shift; | |
137 | ||
138 | foreach my $dep_str (@_) { | |
139 | next unless $dep_str; | |
140 | ||
141 | my $deps = deps_parse($dep_str, reduce_restrictions => 1, | |
142 | build_dep => 1, | |
143 | build_profiles => \@build_profiles); | |
144 | ||
145 | # We add every sub-dependencies as we cannot know which package in | |
146 | # an OR dependency has been effectively used. | |
147 | deps_iterate($deps, sub { | |
148 | push @{$pkgs}, | |
149 | $_[0]->{package} . (defined $_[0]->{archqual} ? ':' . $_[0]->{archqual} : ''); | |
150 | 1 | |
151 | }); | |
152 | } | |
153 | } | |
154 | ||
155 | sub collect_installed_builddeps { | |
156 | my $control = shift; | |
157 | ||
158 | my ($facts, $depends, $essential_pkgs) = parse_status("$admindir/status"); | |
159 | my %seen_pkgs; | |
160 | my @unprocessed_pkgs; | |
161 | ||
162 | # Parse essential packages list. | |
163 | append_deps(\@unprocessed_pkgs, | |
164 | @{$essential_pkgs}, | |
165 | run_vendor_hook('builtin-build-depends'), | |
166 | $control->get_source->{'Build-Depends'}); | |
167 | ||
168 | if (build_has_any(BUILD_ARCH_DEP)) { | |
169 | append_deps(\@unprocessed_pkgs, | |
170 | $control->get_source->{'Build-Depends-Arch'}); | |
171 | } | |
172 | ||
173 | if (build_has_any(BUILD_ARCH_INDEP)) { | |
174 | append_deps(\@unprocessed_pkgs, | |
175 | $control->get_source->{'Build-Depends-Indep'}); | |
176 | } | |
177 | ||
178 | my $installed_deps = Dpkg::Deps::AND->new(); | |
179 | ||
180 | while (my $pkg_name = shift @unprocessed_pkgs) { | |
181 | next if $seen_pkgs{$pkg_name}; | |
182 | $seen_pkgs{$pkg_name} = 1; | |
183 | ||
184 | my $required_architecture; | |
185 | if ($pkg_name =~ /\A(.*):(.*)\z/) { | |
186 | $pkg_name = $1; | |
187 | my $arch = $2; | |
188 | $required_architecture = $arch if $arch !~ /\A(?:all|any|native)\Z/ | |
189 | } | |
190 | my $pkg; | |
191 | my $qualified_pkg_name; | |
192 | foreach my $installed_pkg (@{$facts->{pkg}->{$pkg_name}}) { | |
193 | if (!defined $required_architecture || | |
194 | $required_architecture eq $installed_pkg->{architecture}) { | |
195 | $pkg = $installed_pkg; | |
196 | $qualified_pkg_name = $pkg_name . ':' . $installed_pkg->{architecture}; | |
197 | last; | |
198 | } | |
199 | } | |
200 | if (defined $pkg) { | |
201 | my $version = $pkg->{version}; | |
202 | my $architecture = $pkg->{architecture}; | |
203 | my $new_deps_str = defined $depends->{$qualified_pkg_name} ? deps_concat(@{$depends->{$qualified_pkg_name}}) : ''; | |
204 | my $new_deps = deps_parse($new_deps_str); | |
205 | if (!defined $required_architecture) { | |
206 | $installed_deps->add(Dpkg::Deps::Simple->new("$pkg_name (= $version)")); | |
207 | } else { | |
208 | $installed_deps->add(Dpkg::Deps::Simple->new("$qualified_pkg_name (= $version)")); | |
209 | ||
210 | # Dependencies of foreign packages are also foreign packages | |
211 | # (or Arch:all) so we need to qualify them as well. We figure | |
212 | # out if the package is actually foreign by searching for an | |
213 | # installed package of the right architecture. | |
214 | deps_iterate($new_deps, sub { | |
215 | my $dep = shift; | |
216 | return unless defined $facts->{pkg}->{$dep->{package}}; | |
217 | $dep->{archqual} //= $architecture | |
218 | if any { $_[0]->{architecture} eq $architecture }, @{$facts->{pkg}->{$dep->{package}}}; | |
219 | 1; | |
220 | }); | |
221 | } | |
222 | ||
223 | # We add every sub-dependencies as we cannot know which package | |
224 | # in an OR dependency has been effectively used. | |
225 | deps_iterate($new_deps, sub { | |
226 | push @unprocessed_pkgs, | |
227 | $_[0]->{package} . (defined $_[0]->{archqual} ? ':' . $_[0]->{archqual} : ''); | |
228 | 1 | |
229 | }); | |
230 | } elsif (defined $facts->{virtualpkg}->{$pkg_name}) { | |
231 | # virtual package: we cannot know for sure which implementation | |
232 | # is the one that has been used, so let's add them all... | |
233 | foreach my $provided (@{$facts->{virtualpkg}->{$pkg_name}}) { | |
234 | my ($provided_by, $provided_rel, $provided_ver) = @{$provided}; | |
235 | push @unprocessed_pkgs, $provided_by; | |
236 | } | |
237 | } | |
238 | # else: it is a package in an OR dependency that has been otherwise | |
239 | # satisfied. | |
240 | } | |
241 | $installed_deps->simplify_deps(Dpkg::Deps::KnownFacts->new()); | |
242 | $installed_deps->sort(); | |
243 | $installed_deps = "\n" . $installed_deps->output(); | |
244 | $installed_deps =~ s/, /,\n/g; | |
245 | ||
246 | return $installed_deps; | |
247 | } | |
248 | ||
249 | sub cleansed_environment { | |
250 | # Consider only whitelisted variables which are not supposed to leak | |
251 | # local user information. | |
252 | my %env = map { | |
253 | $_ => $ENV{$_} | |
254 | } grep { | |
255 | exists $ENV{$_} | |
256 | } get_build_env_whitelist(); | |
257 | ||
258 | # Record flags from dpkg-buildflags. | |
259 | my $bf = Dpkg::BuildFlags->new(); | |
260 | $bf->load_system_config(); | |
261 | $bf->load_user_config(); | |
262 | $bf->load_environment_config(); | |
263 | foreach my $flag ($bf->list()) { | |
264 | next if $bf->get_origin($flag) eq 'vendor'; | |
265 | ||
266 | # We do not need to record *_{STRIP,APPEND,PREPEND} as they | |
267 | # have been used already to compute the above value. | |
268 | $env{"DEB_${flag}_SET"} = $bf->get($flag); | |
269 | } | |
270 | ||
271 | return join "\n", map { $_ . '="' . ($env{$_} =~ s/"/\\"/gr) . '"' } | |
272 | sort keys %env; | |
273 | } | |
274 | ||
275 | sub version { | |
276 | printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION; | |
277 | ||
278 | printf g_(' | |
279 | This is free software; see the GNU General Public License version 2 or | |
280 | later for copying conditions. There is NO warranty. | |
281 | '); | |
282 | } | |
283 | ||
284 | sub usage { | |
285 | printf g_( | |
286 | 'Usage: %s [<option>...]') | |
287 | . "\n\n" . g_( | |
288 | "Options: | |
289 | --build=<type>[,...] specify the build <type>: full, source, binary, | |
290 | any, all (default is \'full\'). | |
291 | -c<control-file> get control info from this file. | |
292 | -l<changelog-file> get per-version info from this file. | |
293 | -f<files-list-file> get .deb files list from this file. | |
294 | -F<changelog-format> force changelog format. | |
295 | -O[<buildinfo-file>] write to stdout (or <buildinfo-file>). | |
296 | -u<upload-files-dir> directory with files (default is '..'). | |
297 | --always-include-path always include Build-Path. | |
298 | --admindir=<directory> change the administrative directory. | |
299 | -?, --help show this help message. | |
300 | --version show the version. | |
301 | "), $Dpkg::PROGNAME; | |
302 | } | |
303 | ||
304 | my $build_opts = Dpkg::BuildOptions->new(); | |
305 | $build_opts->parse_features('buildinfo', \%use_feature); | |
306 | ||
307 | while (@ARGV) { | |
308 | $_ = shift @ARGV ; | |
309 | if (m/^--build=(.*)$/) { | |
310 | set_build_type_from_options($1, $_); | |
311 | } elsif (m/^-c(.*)$/) { | |
312 | $controlfile = $1; | |
313 | } elsif (m/^-l(.*)$/) { | |
314 | $changelogfile = $1; | |
315 | } elsif (m/^-f(.*)$/) { | |
316 | $fileslistfile = $1; | |
317 | } elsif (m/^-F([0-9a-z]+)$/) { | |
318 | $changelogformat = $1; | |
319 | } elsif (m/^-u(.*)$/) { | |
320 | $uploadfilesdir = $1; | |
321 | } elsif (m/^-O$/) { | |
322 | $stdout = 1; | |
323 | } elsif (m/^-O(.*)$/) { | |
324 | $outputfile = $1; | |
325 | } elsif (m/^--buildinfo-id=.*$/) { | |
326 | # Deprecated option | |
327 | warning('--buildinfo-id is deprecated, it is without effect'); | |
328 | } elsif (m/^--always-include-path$/) { | |
329 | $use_feature{path} = 1; | |
330 | } elsif (m/^--admindir=(.*)$/) { | |
331 | $admindir = $1; | |
332 | } elsif (m/^-(?:\?|-help)$/) { | |
333 | usage(); | |
334 | exit(0); | |
335 | } elsif (m/^--version$/) { | |
336 | version(); | |
337 | exit(0); | |
338 | } else { | |
339 | usageerr(g_("unknown option '%s'"), $_); | |
340 | } | |
341 | } | |
342 | ||
343 | my $control = Dpkg::Control::Info->new($controlfile); | |
344 | my $fields = Dpkg::Control->new(type => CTRL_FILE_BUILDINFO); | |
345 | my $dist = Dpkg::Dist::Files->new(); | |
346 | ||
347 | # Retrieve info from the current changelog entry. | |
348 | my %options = (file => $changelogfile); | |
349 | $options{changelogformat} = $changelogformat if $changelogformat; | |
350 | my $changelog = changelog_parse(%options); | |
351 | ||
352 | # Retrieve info from the former changelog entry to handle binNMUs. | |
353 | $options{count} = 1; | |
354 | $options{offset} = 1; | |
355 | my $prev_changelog = changelog_parse(%options); | |
356 | ||
357 | my $sourceversion = $changelog->{'Binary-Only'} ? | |
358 | $prev_changelog->{'Version'} : $changelog->{'Version'}; | |
359 | my $binaryversion = Dpkg::Version->new($changelog->{'Version'}); | |
360 | ||
361 | # Include .dsc if available. | |
362 | my $spackage = $changelog->{'Source'}; | |
363 | (my $sversion = $sourceversion) =~ s/^\d+://; | |
364 | ||
365 | if (build_has_any(BUILD_SOURCE)) { | |
366 | my $dsc = "${spackage}_${sversion}.dsc"; | |
367 | ||
368 | $checksums->add_from_file("$uploadfilesdir/$dsc", key => $dsc); | |
369 | ||
370 | push @archvalues, 'source'; | |
371 | } | |
372 | ||
373 | my $dist_count = 0; | |
374 | ||
375 | $dist_count = $dist->load($fileslistfile) if -e $fileslistfile; | |
376 | ||
377 | if (build_has_any(BUILD_BINARY)) { | |
378 | error(g_('binary build with no binary artifacts found; .buildinfo is meaningless')) | |
379 | if $dist_count == 0; | |
380 | ||
381 | foreach my $file ($dist->get_files()) { | |
382 | # Make us a bit idempotent. | |
383 | next if $file->{filename} =~ m/\.buildinfo$/; | |
384 | ||
385 | my $path = "$uploadfilesdir/$file->{filename}"; | |
386 | $checksums->add_from_file($path, key => $file->{filename}); | |
387 | ||
388 | if (defined $file->{package_type} and $file->{package_type} =~ m/^u?deb$/) { | |
389 | push @archvalues, $file->{arch} | |
390 | if defined $file->{arch} and not $archadded{$file->{arch}}++; | |
391 | } | |
392 | } | |
393 | } | |
394 | ||
395 | $fields->{'Format'} = $buildinfo_format; | |
396 | $fields->{'Source'} = $spackage; | |
397 | $fields->{'Binary'} = join(' ', map { $_->{'Package'} } $control->get_packages()); | |
398 | # Avoid overly long line by splitting over multiple lines. | |
399 | if (length($fields->{'Binary'}) > 980) { | |
400 | $fields->{'Binary'} =~ s/(.{0,980}) /$1\n/g; | |
401 | } | |
402 | ||
403 | $fields->{'Architecture'} = join ' ', sort @archvalues; | |
404 | $fields->{'Version'} = $binaryversion; | |
405 | ||
406 | if ($changelog->{'Binary-Only'}) { | |
407 | $fields->{'Source'} .= ' (' . $sourceversion . ')'; | |
408 | $fields->{'Binary-Only-Changes'} = | |
409 | $changelog->{'Changes'} . "\n\n" | |
410 | . ' -- ' . $changelog->{'Maintainer'} | |
411 | . ' ' . $changelog->{'Date'}; | |
412 | } | |
413 | ||
414 | $fields->{'Build-Origin'} = get_current_vendor(); | |
415 | $fields->{'Build-Architecture'} = get_build_arch(); | |
416 | $fields->{'Build-Date'} = get_build_date(); | |
417 | ||
418 | my $cwd = cwd(); | |
419 | if ($use_feature{path}) { | |
420 | $fields->{'Build-Path'} = $cwd; | |
421 | } else { | |
422 | # Only include the build path if its root path is considered acceptable | |
423 | # by the vendor. | |
424 | foreach my $root_path (run_vendor_hook('builtin-system-build-paths')) { | |
425 | if (index($cwd, $root_path) == 0) { | |
426 | $fields->{'Build-Path'} = $cwd; | |
427 | last; | |
428 | } | |
429 | } | |
430 | } | |
431 | ||
432 | $checksums->export_to_control($fields); | |
433 | ||
434 | $fields->{'Installed-Build-Depends'} = collect_installed_builddeps($control); | |
435 | ||
436 | $fields->{'Environment'} = "\n" . cleansed_environment(); | |
437 | ||
438 | # Generate the buildinfo filename. | |
439 | if ($stdout) { | |
440 | # Nothing to do. | |
441 | } elsif (defined $outputfile) { | |
442 | $buildinfo = basename($outputfile); | |
443 | } else { | |
444 | my $arch; | |
445 | ||
446 | if (build_has_any(BUILD_ARCH_DEP)) { | |
447 | $arch = get_host_arch(); | |
448 | } elsif (build_has_any(BUILD_ARCH_INDEP)) { | |
449 | $arch = 'all'; | |
450 | } elsif (build_has_any(BUILD_SOURCE)) { | |
451 | $arch = 'source'; | |
452 | } | |
453 | ||
454 | my $bversion = $binaryversion->as_string(omit_epoch => 1); | |
455 | $buildinfo = "${spackage}_${bversion}_${arch}.buildinfo"; | |
456 | $outputfile = "$uploadfilesdir/$buildinfo"; | |
457 | } | |
458 | ||
459 | # Write out the generated .buildinfo file. | |
460 | ||
461 | if ($stdout) { | |
462 | $fields->output(\*STDOUT); | |
463 | } else { | |
464 | my $section = $control->get_source->{'Section'} || '-'; | |
465 | my $priority = $control->get_source->{'Priority'} || '-'; | |
466 | ||
467 | # Obtain a lock on debian/control to avoid simultaneous updates | |
468 | # of debian/files when parallel building is in use | |
469 | my $lockfh; | |
470 | my $lockfile = 'debian/control'; | |
471 | $lockfile = $controlfile if not -e $lockfile; | |
472 | ||
473 | sysopen $lockfh, $lockfile, O_WRONLY | |
474 | or syserr(g_('cannot write %s'), $lockfile); | |
475 | file_lock($lockfh, $lockfile); | |
476 | ||
477 | $dist = Dpkg::Dist::Files->new(); | |
478 | $dist->load($fileslistfile) if -e $fileslistfile; | |
479 | ||
480 | foreach my $file ($dist->get_files()) { | |
481 | if (defined $file->{package} && | |
482 | $file->{package} eq $spackage && | |
483 | $file->{package_type} eq 'buildinfo' && | |
484 | (debarch_eq($file->{arch}, $fields->{'Architecture'}) || | |
485 | debarch_eq($file->{arch}, 'all') || | |
486 | debarch_eq($file->{arch}, 'source'))) { | |
487 | $dist->del_file($file->{filename}); | |
488 | } | |
489 | } | |
490 | ||
491 | $dist->add_file($buildinfo, $section, $priority); | |
492 | $dist->save("$fileslistfile.new"); | |
493 | ||
494 | rename "$fileslistfile.new", $fileslistfile | |
495 | or syserr(g_('install new files list file')); | |
496 | ||
497 | # Release the lock | |
498 | close $lockfh or syserr(g_('cannot close %s'), $lockfile); | |
499 | ||
500 | $fields->save("$outputfile.new"); | |
501 | ||
502 | rename "$outputfile.new", $outputfile | |
503 | or syserr(g_("cannot install output buildinfo file '%s'"), $outputfile); | |
504 | } | |
505 | ||
506 | 1; |