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
25use strict;
26use warnings;
27
28use List::Util qw(any);
29use Cwd;
30use File::Basename;
31use POSIX qw(:fcntl_h :locale_h strftime);
32
33use Dpkg ();
34use Dpkg::Gettext;
35use Dpkg::Checksums;
36use Dpkg::ErrorHandling;
37use Dpkg::Arch qw(get_build_arch get_host_arch debarch_eq);
38use Dpkg::Build::Types;
39use Dpkg::Build::Info qw(get_build_env_whitelist);
40use Dpkg::BuildOptions;
41use Dpkg::BuildFlags;
42use Dpkg::BuildProfiles qw(get_build_profiles);
43use Dpkg::Control::Info;
44use Dpkg::Control::Fields;
45use Dpkg::Control;
46use Dpkg::Changelog::Parse;
47use Dpkg::Deps;
48use Dpkg::Dist::Files;
49use Dpkg::Lock;
50use Dpkg::Version;
51use Dpkg::Vendor qw(get_current_vendor run_vendor_hook);
52
53textdomain('dpkg-dev');
54
55my $controlfile = 'debian/control';
56my $changelogfile = 'debian/changelog';
57my $changelogformat;
58my $fileslistfile = 'debian/files';
59my $uploadfilesdir = '..';
60my $outputfile;
61my $stdout = 0;
62my $admindir = $Dpkg::ADMINDIR;
63my %use_feature = (
64    kernel => 0,
65    path => 0,
66);
67my @build_profiles = get_build_profiles();
68my $buildinfo_format = '1.0';
69my $buildinfo;
70
71my $checksums = Dpkg::Checksums->new();
72my %archadded;
73my @archvalues;
74
75sub get_build_date {
76    my $date;
77
78    setlocale(LC_TIME, 'C');
79    $date = strftime('%a, %d %b %Y %T %z', localtime);
80    setlocale(LC_TIME, '');
81
82    return $date;
83}
84
85# There is almost the same function in dpkg-checkbuilddeps, they probably
86# should be factored out.
87sub parse_status {
88    my $status = shift;
89
90    my $facts = Dpkg::Deps::KnownFacts->new();
91    my %depends;
92    my @essential_pkgs;
93
94    local $/ = '';
95    open my $status_fh, '<', $status or syserr(g_('cannot open %s'), $status);
96    while (<$status_fh>) {
97        next unless /^Status: .*ok installed$/m;
98
99        my ($package) = /^Package: (.*)$/m;
100        my ($version) = /^Version: (.*)$/m;
101        my ($arch) = /^Architecture: (.*)$/m;
102        my ($multiarch) = /^Multi-Arch: (.*)$/m;
103
104        $facts->add_installed_package($package, $version, $arch, $multiarch);
105
106        if (/^Essential: yes$/m) {
107            push @essential_pkgs, $package;
108        }
109
110        if (/^Provides: (.*)$/m) {
111            my $provides = deps_parse($1, reduce_arch => 1, union => 1);
112
113            next if not defined $provides;
114
115            deps_iterate($provides, sub {
116                my $dep = shift;
117                $facts->add_provided_package($dep->{package}, $dep->{relation},
118                                             $dep->{version}, $package);
119            });
120        }
121
122        foreach my $deptype (qw(Pre-Depends Depends)) {
123            next unless /^$deptype: (.*)$/m;
124
125            my $depends = $1;
126            foreach (split /,\s*/, $depends) {
127                push @{$depends{"$package:$arch"}}, $_;
128            }
129        }
130    }
131    close $status_fh;
132
133    return ($facts, \%depends, \@essential_pkgs);
134}
135
136sub append_deps {
137    my $pkgs = shift;
138
139    foreach my $dep_str (@_) {
140        next unless $dep_str;
141
142        my $deps = deps_parse($dep_str, reduce_restrictions => 1,
143                              build_dep => 1,
144                              build_profiles => \@build_profiles);
145
146        # We add every sub-dependencies as we cannot know which package in
147        # an OR dependency has been effectively used.
148        deps_iterate($deps, sub {
149            push @{$pkgs},
150                $_[0]->{package} . (defined $_[0]->{archqual} ? ':' . $_[0]->{archqual} : '');
151            1
152        });
153    }
154}
155
156sub collect_installed_builddeps {
157    my $control = shift;
158
159    my ($facts, $depends, $essential_pkgs) = parse_status("$admindir/status");
160    my %seen_pkgs;
161    my @unprocessed_pkgs;
162
163    # Parse essential packages list.
164    append_deps(\@unprocessed_pkgs,
165                @{$essential_pkgs},
166                run_vendor_hook('builtin-build-depends'),
167                $control->get_source->{'Build-Depends'});
168
169    if (build_has_any(BUILD_ARCH_DEP)) {
170        append_deps(\@unprocessed_pkgs,
171                    $control->get_source->{'Build-Depends-Arch'});
172    }
173
174    if (build_has_any(BUILD_ARCH_INDEP)) {
175        append_deps(\@unprocessed_pkgs,
176                    $control->get_source->{'Build-Depends-Indep'});
177    }
178
179    my $installed_deps = Dpkg::Deps::AND->new();
180
181    while (my $pkg_name = shift @unprocessed_pkgs) {
182        next if $seen_pkgs{$pkg_name};
183        $seen_pkgs{$pkg_name} = 1;
184
185        my $required_architecture;
186        if ($pkg_name =~ /\A(.*):(.*)\z/) {
187            $pkg_name = $1;
188            my $arch = $2;
189            $required_architecture = $arch if $arch !~ /\A(?:all|any|native)\Z/
190        }
191        my $pkg;
192        my $qualified_pkg_name;
193        foreach my $installed_pkg (@{$facts->{pkg}->{$pkg_name}}) {
194            if (!defined $required_architecture ||
195                $required_architecture eq $installed_pkg->{architecture}) {
196                $pkg = $installed_pkg;
197                $qualified_pkg_name = $pkg_name . ':' . $installed_pkg->{architecture};
198                last;
199            }
200        }
201        if (defined $pkg) {
202            my $version = $pkg->{version};
203            my $architecture = $pkg->{architecture};
204            my $new_deps_str = defined $depends->{$qualified_pkg_name} ? deps_concat(@{$depends->{$qualified_pkg_name}}) : '';
205            my $new_deps = deps_parse($new_deps_str);
206            if (!defined $required_architecture) {
207                $installed_deps->add(Dpkg::Deps::Simple->new("$pkg_name (= $version)"));
208            } else {
209                $installed_deps->add(Dpkg::Deps::Simple->new("$qualified_pkg_name (= $version)"));
210
211                # Dependencies of foreign packages are also foreign packages
212                # (or Arch:all) so we need to qualify them as well. We figure
213                # out if the package is actually foreign by searching for an
214                # installed package of the right architecture.
215                deps_iterate($new_deps, sub {
216                    my $dep = shift;
217                    return unless defined $facts->{pkg}->{$dep->{package}};
218                    $dep->{archqual} //= $architecture
219                        if any { $_[0]->{architecture} eq $architecture }, @{$facts->{pkg}->{$dep->{package}}};
220                    1;
221                });
222            }
223
224            # We add every sub-dependencies as we cannot know which package
225            # in an OR dependency has been effectively used.
226            deps_iterate($new_deps, sub {
227                push @unprocessed_pkgs,
228                     $_[0]->{package} . (defined $_[0]->{archqual} ? ':' . $_[0]->{archqual} : '');
229                1
230            });
231        } elsif (defined $facts->{virtualpkg}->{$pkg_name}) {
232            # virtual package: we cannot know for sure which implementation
233            # is the one that has been used, so let's add them all...
234            foreach my $provided (@{$facts->{virtualpkg}->{$pkg_name}}) {
235                push @unprocessed_pkgs, $provided->{provider};
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
249sub 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
275sub version {
276    printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
277
278    printf g_('
279This is free software; see the GNU General Public License version 2 or
280later for copying conditions. There is NO warranty.
281');
282}
283
284sub 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-kernel  always include Build-Kernel-Version.
298  --always-include-path    always include Build-Path.
299  --admindir=<directory>   change the administrative directory.
300  -?, --help               show this help message.
301      --version            show the version.
302"), $Dpkg::PROGNAME;
303}
304
305my $build_opts = Dpkg::BuildOptions->new();
306$build_opts->parse_features('buildinfo', \%use_feature);
307
308while (@ARGV) {
309    $_ = shift @ARGV ;
310    if (m/^--build=(.*)$/) {
311        set_build_type_from_options($1, $_);
312    } elsif (m/^-c(.*)$/) {
313        $controlfile = $1;
314    } elsif (m/^-l(.*)$/) {
315        $changelogfile = $1;
316    } elsif (m/^-f(.*)$/) {
317        $fileslistfile = $1;
318    } elsif (m/^-F([0-9a-z]+)$/) {
319        $changelogformat = $1;
320    } elsif (m/^-u(.*)$/) {
321        $uploadfilesdir = $1;
322    } elsif (m/^-O$/) {
323        $stdout = 1;
324    } elsif (m/^-O(.*)$/) {
325        $outputfile = $1;
326    } elsif (m/^--buildinfo-id=.*$/) {
327        # Deprecated option
328        warning('--buildinfo-id is deprecated, it is without effect');
329    } elsif (m/^--always-include-kernel$/) {
330        $use_feature{kernel} = 1;
331    } elsif (m/^--always-include-path$/) {
332        $use_feature{path} = 1;
333    } elsif (m/^--admindir=(.*)$/) {
334        $admindir = $1;
335    } elsif (m/^-(?:\?|-help)$/) {
336        usage();
337        exit(0);
338    } elsif (m/^--version$/) {
339        version();
340        exit(0);
341    } else {
342        usageerr(g_("unknown option '%s'"), $_);
343    }
344}
345
346my $control = Dpkg::Control::Info->new($controlfile);
347my $fields = Dpkg::Control->new(type => CTRL_FILE_BUILDINFO);
348my $dist = Dpkg::Dist::Files->new();
349
350# Retrieve info from the current changelog entry.
351my %options = (file => $changelogfile);
352$options{changelogformat} = $changelogformat if $changelogformat;
353my $changelog = changelog_parse(%options);
354
355# Retrieve info from the former changelog entry to handle binNMUs.
356$options{count} = 1;
357$options{offset} = 1;
358my $prev_changelog = changelog_parse(%options);
359
360my $sourceversion = $changelog->{'Binary-Only'} ?
361                    $prev_changelog->{'Version'} : $changelog->{'Version'};
362my $binaryversion = Dpkg::Version->new($changelog->{'Version'});
363
364# Include .dsc if available.
365my $spackage = $changelog->{'Source'};
366(my $sversion = $sourceversion) =~ s/^\d+://;
367
368if (build_has_any(BUILD_SOURCE)) {
369    my $dsc = "${spackage}_${sversion}.dsc";
370
371    $checksums->add_from_file("$uploadfilesdir/$dsc", key => $dsc);
372
373    push @archvalues, 'source';
374}
375
376my $dist_count = 0;
377
378$dist_count = $dist->load($fileslistfile) if -e $fileslistfile;
379
380if (build_has_any(BUILD_BINARY)) {
381    error(g_('binary build with no binary artifacts found; .buildinfo is meaningless'))
382        if $dist_count == 0;
383
384    foreach my $file ($dist->get_files()) {
385        # Make us a bit idempotent.
386        next if $file->{filename} =~ m/\.buildinfo$/;
387
388        my $path = "$uploadfilesdir/$file->{filename}";
389        $checksums->add_from_file($path, key => $file->{filename});
390
391        if (defined $file->{package_type} and $file->{package_type} =~ m/^u?deb$/) {
392            push @archvalues, $file->{arch}
393                if defined $file->{arch} and not $archadded{$file->{arch}}++;
394        }
395    }
396}
397
398$fields->{'Format'} = $buildinfo_format;
399$fields->{'Source'} = $spackage;
400$fields->{'Binary'} = join(' ', map { $_->{'Package'} } $control->get_packages());
401# Avoid overly long line by splitting over multiple lines.
402if (length($fields->{'Binary'}) > 980) {
403    $fields->{'Binary'} =~ s/(.{0,980}) /$1\n/g;
404}
405
406$fields->{'Architecture'} = join ' ', sort @archvalues;
407$fields->{'Version'} = $binaryversion;
408
409if ($changelog->{'Binary-Only'}) {
410    $fields->{'Source'} .= ' (' . $sourceversion . ')';
411    $fields->{'Binary-Only-Changes'} =
412        $changelog->{'Changes'} . "\n\n"
413        . ' -- ' . $changelog->{'Maintainer'}
414        . '  ' . $changelog->{'Date'};
415}
416
417$fields->{'Build-Origin'} = get_current_vendor();
418$fields->{'Build-Architecture'} = get_build_arch();
419$fields->{'Build-Date'} = get_build_date();
420
421if ($use_feature{kernel}) {
422    my (undef, undef, $kern_rel, $kern_ver, undef) = POSIX::uname();
423    $fields->{'Build-Kernel-Version'} = "$kern_rel $kern_ver";
424}
425
426my $cwd = getcwd();
427if ($use_feature{path}) {
428    $fields->{'Build-Path'} = $cwd;
429} else {
430    # Only include the build path if its root path is considered acceptable
431    # by the vendor.
432    foreach my $root_path (run_vendor_hook('builtin-system-build-paths')) {
433        if (index($cwd, $root_path) == 0) {
434            $fields->{'Build-Path'} = $cwd;
435            last;
436        }
437    }
438}
439
440$fields->{'Build-Tainted-By'} = "\n" . join "\n", run_vendor_hook('build-tainted-by');
441
442$checksums->export_to_control($fields);
443
444$fields->{'Installed-Build-Depends'} = collect_installed_builddeps($control);
445
446$fields->{'Environment'} = "\n" . cleansed_environment();
447
448# Generate the buildinfo filename.
449if ($stdout) {
450    # Nothing to do.
451} elsif (defined $outputfile) {
452    $buildinfo = basename($outputfile);
453} else {
454    my $arch;
455
456    if (build_has_any(BUILD_ARCH_DEP)) {
457        $arch = get_host_arch();
458    } elsif (build_has_any(BUILD_ARCH_INDEP)) {
459        $arch = 'all';
460    } elsif (build_has_any(BUILD_SOURCE)) {
461        $arch = 'source';
462    }
463
464    my $bversion = $binaryversion->as_string(omit_epoch => 1);
465    $buildinfo = "${spackage}_${bversion}_${arch}.buildinfo";
466    $outputfile = "$uploadfilesdir/$buildinfo";
467}
468
469# Write out the generated .buildinfo file.
470
471if ($stdout) {
472    $fields->output(\*STDOUT);
473} else {
474    my $section = $control->get_source->{'Section'} || '-';
475    my $priority = $control->get_source->{'Priority'} || '-';
476
477    # Obtain a lock on debian/control to avoid simultaneous updates
478    # of debian/files when parallel building is in use
479    my $lockfh;
480    my $lockfile = 'debian/control';
481    $lockfile = $controlfile if not -e $lockfile;
482
483    sysopen $lockfh, $lockfile, O_WRONLY
484        or syserr(g_('cannot write %s'), $lockfile);
485    file_lock($lockfh, $lockfile);
486
487    $dist = Dpkg::Dist::Files->new();
488    $dist->load($fileslistfile) if -e $fileslistfile;
489
490    foreach my $file ($dist->get_files()) {
491        if (defined $file->{package} &&
492            $file->{package} eq $spackage &&
493            $file->{package_type} eq 'buildinfo' &&
494            (debarch_eq($file->{arch}, $fields->{'Architecture'}) ||
495             debarch_eq($file->{arch}, 'all') ||
496             debarch_eq($file->{arch}, 'source'))) {
497            $dist->del_file($file->{filename});
498        }
499    }
500
501    $dist->add_file($buildinfo, $section, $priority);
502    $dist->save("$fileslistfile.new");
503
504    rename "$fileslistfile.new", $fileslistfile
505        or syserr(g_('install new files list file'));
506
507    # Release the lock
508    close $lockfh or syserr(g_('cannot close %s'), $lockfile);
509
510    $fields->save("$outputfile.new");
511
512    rename "$outputfile.new", $outputfile
513        or syserr(g_("cannot install output buildinfo file '%s'"), $outputfile);
514}
515
5161;
517