diff options
Diffstat (limited to 'scripts/dpkg-genbuildinfo.pl')
| -rwxr-xr-x | scripts/dpkg-genbuildinfo.pl | 597 |
1 files changed, 597 insertions, 0 deletions
diff --git a/scripts/dpkg-genbuildinfo.pl b/scripts/dpkg-genbuildinfo.pl new file mode 100755 index 0000000..ae0c125 --- /dev/null +++ b/scripts/dpkg-genbuildinfo.pl @@ -0,0 +1,597 @@ +#!/usr/bin/perl +# +# dpkg-genbuildinfo +# +# Copyright © 1996 Ian Jackson +# Copyright © 2000,2001 Wichert Akkerman +# Copyright © 2003-2013 Yann Dirson <dirson@debian.org> +# Copyright © 2006-2016 Guillem Jover <guillem@debian.org> +# Copyright © 2014 Niko Tyni <ntyni@debian.org> +# Copyright © 2014-2015 Jérémy Bobbio <lunar@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +use strict; +use warnings; + +use List::Util qw(any); +use Cwd; +use File::Basename; +use File::Temp; +use POSIX qw(:fcntl_h :locale_h strftime); + +use Dpkg (); +use Dpkg::Gettext; +use Dpkg::Checksums; +use Dpkg::ErrorHandling; +use Dpkg::IPC; +use Dpkg::Path qw(find_command); +use Dpkg::Arch qw( + get_build_arch + get_host_arch + debarch_eq debarch_to_gnutriplet +); +use Dpkg::BuildTypes; +use Dpkg::BuildOptions; +use Dpkg::BuildFlags; +use Dpkg::BuildProfiles qw(get_build_profiles); +use Dpkg::BuildInfo qw(get_build_env_allowed); +use Dpkg::Control::Info; +use Dpkg::Control::Fields; +use Dpkg::Control; +use Dpkg::Changelog::Parse; +use Dpkg::Deps; +use Dpkg::Dist::Files; +use Dpkg::Lock; +use Dpkg::Version; +use Dpkg::Vendor qw(get_current_vendor run_vendor_hook); + +textdomain('dpkg-dev'); + +my $controlfile = 'debian/control'; +my $changelogfile = 'debian/changelog'; +my $changelogformat; +my $fileslistfile = 'debian/files'; +my $uploadfilesdir = '..'; +my $outputfile; +my $stdout = 0; +my $admindir = $Dpkg::ADMINDIR; +my %use_feature = ( + kernel => 0, + path => 0, +); +my @build_profiles = get_build_profiles(); +my $buildinfo_format = '1.0'; +my $buildinfo; + +my $checksums = Dpkg::Checksums->new(); +my %distbinaries; +my %archadded; +my @archvalues; + +sub get_build_date { + my $date; + + setlocale(LC_TIME, 'C'); + $date = strftime('%a, %d %b %Y %T %z', localtime); + setlocale(LC_TIME, ''); + + return $date; +} + +# There is almost the same function in dpkg-checkbuilddeps, they probably +# should be factored out. +sub parse_status { + my $status = shift; + + my $facts = Dpkg::Deps::KnownFacts->new(); + my %depends; + my @essential_pkgs; + + local $/ = ''; + open my $status_fh, '<', $status or syserr(g_('cannot open %s'), $status); + while (<$status_fh>) { + next unless /^Status: .*ok installed$/m; + + my ($package) = /^Package: (.*)$/m; + my ($version) = /^Version: (.*)$/m; + my ($arch) = /^Architecture: (.*)$/m; + my ($multiarch) = /^Multi-Arch: (.*)$/m; + + $facts->add_installed_package($package, $version, $arch, $multiarch); + + if (/^Essential: yes$/m) { + push @essential_pkgs, $package; + } + + if (/^Provides: (.*)$/m) { + my $provides = deps_parse($1, reduce_arch => 1, union => 1); + + next if not defined $provides; + + deps_iterate($provides, sub { + my $dep = shift; + $facts->add_provided_package($dep->{package}, $dep->{relation}, + $dep->{version}, $package); + }); + } + + foreach my $deptype (qw(Pre-Depends Depends)) { + next unless /^$deptype: (.*)$/m; + + my $depends = $1; + foreach (split /,\s*/, $depends) { + push @{$depends{"$package:$arch"}}, $_; + } + } + } + close $status_fh; + + return ($facts, \%depends, \@essential_pkgs); +} + +sub append_deps { + my ($pkgs, @deps) = @_; + + foreach my $dep_str (@deps) { + next unless $dep_str; + + my $deps = deps_parse($dep_str, reduce_restrictions => 1, + build_dep => 1, + build_profiles => \@build_profiles); + + # We add every sub-dependencies as we cannot know which package in + # an OR dependency has been effectively used. + deps_iterate($deps, sub { + my $pkg = shift; + + push @{$pkgs}, + $pkg->{package} . (defined $pkg->{archqual} ? ':' . $pkg->{archqual} : ''); + 1 + }); + } +} + +sub collect_installed_builddeps { + my $control = shift; + + my ($facts, $depends, $essential_pkgs) = parse_status("$admindir/status"); + my %seen_pkgs; + my @unprocessed_pkgs; + + # Parse essential packages list. + append_deps(\@unprocessed_pkgs, + @{$essential_pkgs}, + run_vendor_hook('builtin-build-depends'), + $control->get_source->{'Build-Depends'}); + + if (build_has_any(BUILD_ARCH_DEP)) { + append_deps(\@unprocessed_pkgs, + $control->get_source->{'Build-Depends-Arch'}); + } + + if (build_has_any(BUILD_ARCH_INDEP)) { + append_deps(\@unprocessed_pkgs, + $control->get_source->{'Build-Depends-Indep'}); + } + + my $installed_deps = Dpkg::Deps::AND->new(); + + while (my $pkg_name = shift @unprocessed_pkgs) { + next if $seen_pkgs{$pkg_name}; + $seen_pkgs{$pkg_name} = 1; + + my $required_architecture; + if ($pkg_name =~ /\A(.*):(.*)\z/) { + $pkg_name = $1; + my $arch = $2; + $required_architecture = $arch if $arch !~ /\A(?:all|any|native)\Z/ + } + my $pkg; + my $qualified_pkg_name; + foreach my $installed_pkg (@{$facts->{pkg}->{$pkg_name}}) { + if (!defined $required_architecture || + $required_architecture eq $installed_pkg->{architecture}) { + $pkg = $installed_pkg; + $qualified_pkg_name = $pkg_name . ':' . $installed_pkg->{architecture}; + last; + } + } + if (defined $pkg) { + my $version = $pkg->{version}; + my $architecture = $pkg->{architecture}; + my $new_deps_str = defined $depends->{$qualified_pkg_name} ? deps_concat(@{$depends->{$qualified_pkg_name}}) : ''; + my $new_deps = deps_parse($new_deps_str); + if (!defined $required_architecture) { + $installed_deps->add(Dpkg::Deps::Simple->new("$pkg_name (= $version)")); + } else { + $installed_deps->add(Dpkg::Deps::Simple->new("$qualified_pkg_name (= $version)")); + + # Dependencies of foreign packages are also foreign packages + # (or Arch:all) so we need to qualify them as well. We figure + # out if the package is actually foreign by searching for an + # installed package of the right architecture. + deps_iterate($new_deps, sub { + my $dep = shift; + return unless defined $facts->{pkg}->{$dep->{package}}; + $dep->{archqual} //= $architecture + if any { $_[0]->{architecture} eq $architecture }, @{$facts->{pkg}->{$dep->{package}}}; + 1; + }); + } + + # We add every sub-dependencies as we cannot know which package + # in an OR dependency has been effectively used. + deps_iterate($new_deps, sub { + push @unprocessed_pkgs, + $_[0]->{package} . (defined $_[0]->{archqual} ? ':' . $_[0]->{archqual} : ''); + 1 + }); + } elsif (defined $facts->{virtualpkg}->{$pkg_name}) { + # virtual package: we cannot know for sure which implementation + # is the one that has been used, so let's add them all... + foreach my $provided (@{$facts->{virtualpkg}->{$pkg_name}}) { + push @unprocessed_pkgs, $provided->{provider}; + } + } + # else: it is a package in an OR dependency that has been otherwise + # satisfied. + } + $installed_deps->simplify_deps(Dpkg::Deps::KnownFacts->new()); + $installed_deps->sort(); + $installed_deps = "\n" . $installed_deps->output(); + $installed_deps =~ s/, /,\n/g; + + return $installed_deps; +} + +sub is_cross_executable { + my $host_arch = get_host_arch(); + my $build_arch = get_build_arch(); + + return if $host_arch eq $build_arch; + + # If we are cross-compiling, record whether it was possible to execute + # the host architecture by cross-compiling and executing a small + # host-arch binary. + my $CC = debarch_to_gnutriplet($host_arch) . '-gcc'; + + # If we do not have a cross-compiler, we might be in the process of + # building one or cross-compiling using a language other than C/C++, + # and aborting the build is then not very useful. + return if ! find_command($CC); + + my $crossprog = <<~'CROSSPROG'; + #include <unistd.h> + int main() { write(1, "ok", 2); return 0; } + CROSSPROG + my ($stdout, $stderr) = ('', ''); + my $tmpfh = File::Temp->new(); + spawn( + exec => [ $CC, '-w', '-x', 'c', '-o', $tmpfh->filename, '-' ], + from_string => \$crossprog, + to_string => \$stdout, + error_to_string => \$stderr, + wait_child => 1, + nocheck => 1, + ); + if ($?) { + print { *STDOUT } $stdout; + print { *STDERR } $stderr; + eval { + subprocerr("$CC -w -x c -"); + }; + warning($@); + return; + } + close $tmpfh; + spawn( + exec => [ $tmpfh->filename ], + error_to_file => '/dev/null', + to_string => \$stdout, + wait_child => 1, + nocheck => 1, + ); + + return 1 if $? == 0 && $stdout eq 'ok'; + return 0; +} + +sub get_build_tainted_by { + my @tainted = run_vendor_hook('build-tainted-by'); + + if (is_cross_executable()) { + push @tainted, 'can-execute-cross-built-programs'; + } + + return @tainted; +} + +sub cleansed_environment { + # Consider only allowed variables which are not supposed to leak + # local user information. + my %env = map { + $_ => $ENV{$_} + } grep { + exists $ENV{$_} + } get_build_env_allowed(); + + # Record flags from dpkg-buildflags. + my $bf = Dpkg::BuildFlags->new(); + $bf->load_system_config(); + $bf->load_user_config(); + $bf->load_environment_config(); + foreach my $flag ($bf->list()) { + next if $bf->get_origin($flag) eq 'vendor'; + + # We do not need to record *_{STRIP,APPEND,PREPEND} as they + # have been used already to compute the above value. + $env{"DEB_${flag}_SET"} = $bf->get($flag); + } + + return join "\n", map { $_ . '="' . ($env{$_} =~ s/"/\\"/gr) . '"' } + sort keys %env; +} + +sub version { + printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION; + + printf g_(' +This is free software; see the GNU General Public License version 2 or +later for copying conditions. There is NO warranty. +'); +} + +sub usage { + printf g_( +'Usage: %s [<option>...]') + . "\n\n" . g_( +"Options: + --build=<type>[,...] specify the build <type>: full, source, binary, + any, all (default is \'full\'). + -c<control-file> get control info from this file. + -l<changelog-file> get per-version info from this file. + -f<files-list-file> get .deb files list from this file. + -F<changelog-format> force changelog format. + -O[<buildinfo-file>] write to stdout (or <buildinfo-file>). + -u<upload-files-dir> directory with files (default is '..'). + --always-include-kernel always include Build-Kernel-Version. + --always-include-path always include Build-Path. + --admindir=<directory> change the administrative directory. + -?, --help show this help message. + --version show the version. +"), $Dpkg::PROGNAME; +} + +my $build_opts = Dpkg::BuildOptions->new(); +$build_opts->parse_features('buildinfo', \%use_feature); + +while (@ARGV) { + $_ = shift @ARGV ; + if (m/^--build=(.*)$/) { + set_build_type_from_options($1, $_); + } elsif (m/^-c(.*)$/) { + $controlfile = $1; + } elsif (m/^-l(.*)$/) { + $changelogfile = $1; + } elsif (m/^-f(.*)$/) { + $fileslistfile = $1; + } elsif (m/^-F([0-9a-z]+)$/) { + $changelogformat = $1; + } elsif (m/^-u(.*)$/) { + $uploadfilesdir = $1; + } elsif (m/^-O$/) { + $stdout = 1; + } elsif (m/^-O(.*)$/) { + $outputfile = $1; + } elsif (m/^(--buildinfo-id)=.*$/) { + # Deprecated option + warning(g_('%s is deprecated; it is without effect'), $1); + } elsif (m/^--always-include-kernel$/) { + $use_feature{kernel} = 1; + } elsif (m/^--always-include-path$/) { + $use_feature{path} = 1; + } elsif (m/^--admindir=(.*)$/) { + $admindir = $1; + } elsif (m/^-(?:\?|-help)$/) { + usage(); + exit(0); + } elsif (m/^--version$/) { + version(); + exit(0); + } else { + usageerr(g_("unknown option '%s'"), $_); + } +} + +my $control = Dpkg::Control::Info->new($controlfile); +my $fields = Dpkg::Control->new(type => CTRL_FILE_BUILDINFO); +my $dist = Dpkg::Dist::Files->new(); + +# Retrieve info from the current changelog entry. +my %options = (file => $changelogfile); +$options{changelogformat} = $changelogformat if $changelogformat; +my $changelog = changelog_parse(%options); + +# Retrieve info from the former changelog entry to handle binNMUs. +$options{count} = 1; +$options{offset} = 1; +my $prev_changelog = changelog_parse(%options); + +my $sourceversion = Dpkg::Version->new($changelog->{'Binary-Only'} ? + $prev_changelog->{'Version'} : $changelog->{'Version'}); +my $binaryversion = Dpkg::Version->new($changelog->{'Version'}); + +# Include .dsc if available. +my $spackage = $changelog->{'Source'}; +my $sversion = $sourceversion->as_string(omit_epoch => 1); + +if (build_has_any(BUILD_SOURCE)) { + my $dsc = "${spackage}_${sversion}.dsc"; + + $checksums->add_from_file("$uploadfilesdir/$dsc", key => $dsc); + + push @archvalues, 'source'; +} + +my $dist_count = 0; + +$dist_count = $dist->load($fileslistfile) if -e $fileslistfile; + +if (build_has_any(BUILD_BINARY)) { + error(g_('binary build with no binary artifacts found; .buildinfo is meaningless')) + if $dist_count == 0; + + foreach my $file ($dist->get_files()) { + # Make us a bit idempotent. + next if $file->{filename} =~ m/\.buildinfo$/; + + if (defined $file->{arch}) { + my $arch_all = debarch_eq('all', $file->{arch}); + + next if build_has_none(BUILD_ARCH_INDEP) and $arch_all; + next if build_has_none(BUILD_ARCH_DEP) and not $arch_all; + + $distbinaries{$file->{package}} = 1 if defined $file->{package}; + } + + my $path = "$uploadfilesdir/$file->{filename}"; + $checksums->add_from_file($path, key => $file->{filename}); + + if (defined $file->{package_type} and $file->{package_type} =~ m/^u?deb$/) { + push @archvalues, $file->{arch} + if defined $file->{arch} and not $archadded{$file->{arch}}++; + } + } +} + +$fields->{'Format'} = $buildinfo_format; +$fields->{'Source'} = $spackage; +$fields->{'Binary'} = join(' ', sort keys %distbinaries); +# Avoid overly long line by splitting over multiple lines. +if (length($fields->{'Binary'}) > 980) { + $fields->{'Binary'} =~ s/(.{0,980}) /$1\n/g; +} + +$fields->{'Architecture'} = join ' ', sort @archvalues; +$fields->{'Version'} = $binaryversion; + +if ($changelog->{'Binary-Only'}) { + $fields->{'Source'} .= ' (' . $sourceversion . ')'; + $fields->{'Binary-Only-Changes'} = + $changelog->{'Changes'} . "\n\n" + . ' -- ' . $changelog->{'Maintainer'} + . ' ' . $changelog->{'Date'}; +} + +$fields->{'Build-Origin'} = get_current_vendor(); +$fields->{'Build-Architecture'} = get_build_arch(); +$fields->{'Build-Date'} = get_build_date(); + +if ($use_feature{kernel}) { + my ($kern_rel, $kern_ver); + + ((undef) x 2, $kern_rel, $kern_ver, undef) = POSIX::uname(); + $fields->{'Build-Kernel-Version'} = "$kern_rel $kern_ver"; +} + +my $cwd = getcwd(); +if ($use_feature{path}) { + $fields->{'Build-Path'} = $cwd; +} else { + # Only include the build path if its root path is considered acceptable + # by the vendor. + foreach my $root_path (run_vendor_hook('builtin-system-build-paths')) { + if (index($cwd, $root_path) == 0) { + $fields->{'Build-Path'} = $cwd; + last; + } + } +} + +$fields->{'Build-Tainted-By'} = "\n" . join "\n", get_build_tainted_by(); + +$checksums->export_to_control($fields); + +$fields->{'Installed-Build-Depends'} = collect_installed_builddeps($control); + +$fields->{'Environment'} = "\n" . cleansed_environment(); + +# Generate the buildinfo filename. +if ($stdout) { + # Nothing to do. +} elsif (defined $outputfile) { + $buildinfo = basename($outputfile); +} else { + my $arch; + + if (build_has_any(BUILD_ARCH_DEP)) { + $arch = get_host_arch(); + } elsif (build_has_any(BUILD_ARCH_INDEP)) { + $arch = 'all'; + } elsif (build_has_any(BUILD_SOURCE)) { + $arch = 'source'; + } + + my $bversion = $binaryversion->as_string(omit_epoch => 1); + $buildinfo = "${spackage}_${bversion}_${arch}.buildinfo"; + $outputfile = "$uploadfilesdir/$buildinfo"; +} + +# Write out the generated .buildinfo file. + +if ($stdout) { + $fields->output(\*STDOUT); +} else { + my $section = $control->get_source->{'Section'} || '-'; + my $priority = $control->get_source->{'Priority'} || '-'; + + # Obtain a lock on debian/control to avoid simultaneous updates + # of debian/files when parallel building is in use + my $lockfh; + my $lockfile = 'debian/control'; + $lockfile = $controlfile if not -e $lockfile; + + sysopen $lockfh, $lockfile, O_WRONLY + or syserr(g_('cannot write %s'), $lockfile); + file_lock($lockfh, $lockfile); + + $dist = Dpkg::Dist::Files->new(); + $dist->load($fileslistfile) if -e $fileslistfile; + + foreach my $file ($dist->get_files()) { + if (defined $file->{package} && + $file->{package} eq $spackage && + $file->{package_type} eq 'buildinfo' && + (debarch_eq($file->{arch}, $fields->{'Architecture'}) || + debarch_eq($file->{arch}, 'all') || + debarch_eq($file->{arch}, 'source'))) { + $dist->del_file($file->{filename}); + } + } + + $dist->add_file($buildinfo, $section, $priority); + $dist->save("$fileslistfile.new"); + + rename "$fileslistfile.new", $fileslistfile + or syserr(g_('install new files list file')); + + # Release the lock + close $lockfh or syserr(g_('cannot close %s'), $lockfile); + + $fields->save("$outputfile.new"); + + rename "$outputfile.new", $outputfile + or syserr(g_("cannot install output buildinfo file '%s'"), $outputfile); +} |