JezK
Edit File: dpkg-genbuildinfo
#!/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 = shift; foreach my $dep_str (@_) { 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 { push @{$pkgs}, $_[0]->{package} . (defined $_[0]->{archqual} ? ':' . $_[0]->{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 (undef, undef, $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); } 1;