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