scripts/dpkg-genbuildinfo.pl

   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 List::Util qw(any);
  29 use Cwd;
  30 use File::Basename;
  31 use File::Temp;
  32 use POSIX qw(:fcntl_h :locale_h strftime);
  33
  34 use Dpkg ();
  35 use Dpkg::Gettext;
  36 use Dpkg::Checksums;
  37 use Dpkg::ErrorHandling;
  38 use Dpkg::IPC;
  39 use Dpkg::Path qw(find_command);
  40 use Dpkg::Arch qw(
  41     get_build_arch
  42     get_host_arch
  43     debarch_eq debarch_to_gnutriplet
  44 );
  45 use Dpkg::BuildTypes;
  46 use Dpkg::BuildOptions;
  47 use Dpkg::BuildFlags;
  48 use Dpkg::BuildProfiles qw(get_build_profiles);
  49 use Dpkg::BuildInfo qw(get_build_env_allowed);
  50 use Dpkg::Control::Info;
  51 use Dpkg::Control::Fields;
  52 use Dpkg::Control;
  53 use Dpkg::Changelog::Parse;
  54 use Dpkg::Deps;
  55 use Dpkg::Dist::Files;
  56 use Dpkg::Lock;
  57 use Dpkg::Version;
  58 use Dpkg::Vendor qw(get_current_vendor run_vendor_hook);
  59
  60 textdomain('dpkg-dev');
  61
  62 my $controlfile = 'debian/control';
  63 my $changelogfile = 'debian/changelog';
  64 my $changelogformat;
  65 my $fileslistfile = 'debian/files';
  66 my $uploadfilesdir = '..';
  67 my $outputfile;
  68 my $stdout = 0;
  69 my $admindir = $Dpkg::ADMINDIR;
  70 my %use_feature = (
  71     kernel => 0,
  72     path => 0,
  73 );
  74 my @build_profiles = get_build_profiles();
  75 my $buildinfo_format = '1.0';
  76 my $buildinfo;
  77
  78 my $checksums = Dpkg::Checksums->new();
  79 my %distbinaries;
  80 my %archadded;
  81 my @archvalues;
  82
  83 sub get_build_date {
  84     my $date;
  85
  86     setlocale(LC_TIME, 'C');
  87     $date = strftime('%a, %d %b %Y %T %z', localtime);
  88     setlocale(LC_TIME, '');
  89
  90     return $date;
  91 }
  92
  93 # There is almost the same function in dpkg-checkbuilddeps, they probably
  94 # should be factored out.
  95 sub parse_status {
  96     my $status = shift;
  97
  98     my $facts = Dpkg::Deps::KnownFacts->new();
  99     my %depends;
 100     my @essential_pkgs;
 101
 102     local $/ = '';
 103     open my $status_fh, '<', $status or syserr(g_('cannot open %s'), $status);
 104     while (<$status_fh>) {
 105         next unless /^Status: .*ok installed$/m;
 106
 107         my ($package) = /^Package: (.*)$/m;
 108         my ($version) = /^Version: (.*)$/m;
 109         my ($arch) = /^Architecture: (.*)$/m;
 110         my ($multiarch) = /^Multi-Arch: (.*)$/m;
 111
 112         $facts->add_installed_package($package, $version, $arch, $multiarch);
 113
 114         if (/^Essential: yes$/m) {
 115             push @essential_pkgs, $package;
 116         }
 117
 118         if (/^Provides: (.*)$/m) {
 119             my $provides = deps_parse($1, reduce_arch => 1, union => 1);
 120
 121             next if not defined $provides;
 122
 123             deps_iterate($provides, sub {
 124                 my $dep = shift;
 125                 $facts->add_provided_package($dep->{package}, $dep->{relation},
 126                                              $dep->{version}, $package);
 127             });
 128         }
 129
 130         foreach my $deptype (qw(Pre-Depends Depends)) {
 131             next unless /^$deptype: (.*)$/m;
 132
 133             my $depends = $1;
 134             foreach (split /,\s*/, $depends) {
 135                 push @{$depends{"$package:$arch"}}, $_;
 136             }
 137         }
 138     }
 139     close $status_fh;
 140
 141     return ($facts, \%depends, \@essential_pkgs);
 142 }
 143
 144 sub append_deps {
 145     my ($pkgs, @deps) = @_;
 146
 147     foreach my $dep_str (@deps) {
 148         next unless $dep_str;
 149
 150         my $deps = deps_parse($dep_str, reduce_restrictions => 1,
 151                               build_dep => 1,
 152                               build_profiles => \@build_profiles);
 153
 154         # We add every sub-dependencies as we cannot know which package in
 155         # an OR dependency has been effectively used.
 156         deps_iterate($deps, sub {
 157             my $pkg = shift;
 158
 159             push @{$pkgs},
 160                 $pkg->{package} . (defined $pkg->{archqual} ? ':' . $pkg->{archqual} : '');
 161             1
 162         });
 163     }
 164 }
 165
 166 sub collect_installed_builddeps {
 167     my $control = shift;
 168
 169     my ($facts, $depends, $essential_pkgs) = parse_status("$admindir/status");
 170     my %seen_pkgs;
 171     my @unprocessed_pkgs;
 172
 173     # Parse essential packages list.
 174     append_deps(\@unprocessed_pkgs,
 175                 @{$essential_pkgs},
 176                 run_vendor_hook('builtin-build-depends'),
 177                 $control->get_source->{'Build-Depends'});
 178
 179     if (build_has_any(BUILD_ARCH_DEP)) {
 180         append_deps(\@unprocessed_pkgs,
 181                     $control->get_source->{'Build-Depends-Arch'});
 182     }
 183
 184     if (build_has_any(BUILD_ARCH_INDEP)) {
 185         append_deps(\@unprocessed_pkgs,
 186                     $control->get_source->{'Build-Depends-Indep'});
 187     }
 188
 189     my $installed_deps = Dpkg::Deps::AND->new();
 190
 191     while (my $pkg_name = shift @unprocessed_pkgs) {
 192         next if $seen_pkgs{$pkg_name};
 193         $seen_pkgs{$pkg_name} = 1;
 194
 195         my $required_architecture;
 196         if ($pkg_name =~ /\A(.*):(.*)\z/) {
 197             $pkg_name = $1;
 198             my $arch = $2;
 199             $required_architecture = $arch if $arch !~ /\A(?:all|any|native)\Z/
 200         }
 201         my $pkg;
 202         my $qualified_pkg_name;
 203         foreach my $installed_pkg (@{$facts->{pkg}->{$pkg_name}}) {
 204             if (!defined $required_architecture ||
 205                 $required_architecture eq $installed_pkg->{architecture}) {
 206                 $pkg = $installed_pkg;
 207                 $qualified_pkg_name = $pkg_name . ':' . $installed_pkg->{architecture};
 208                 last;
 209             }
 210         }
 211         if (defined $pkg) {
 212             my $version = $pkg->{version};
 213             my $architecture = $pkg->{architecture};
 214             my $new_deps_str = defined $depends->{$qualified_pkg_name} ? deps_concat(@{$depends->{$qualified_pkg_name}}) : '';
 215             my $new_deps = deps_parse($new_deps_str);
 216             if (!defined $required_architecture) {
 217                 $installed_deps->add(Dpkg::Deps::Simple->new("$pkg_name (= $version)"));
 218             } else {
 219                 $installed_deps->add(Dpkg::Deps::Simple->new("$qualified_pkg_name (= $version)"));
 220
 221                 # Dependencies of foreign packages are also foreign packages
 222                 # (or Arch:all) so we need to qualify them as well. We figure
 223                 # out if the package is actually foreign by searching for an
 224                 # installed package of the right architecture.
 225                 deps_iterate($new_deps, sub {
 226                     my $dep = shift;
 227                     return unless defined $facts->{pkg}->{$dep->{package}};
 228                     $dep->{archqual} //= $architecture
 229                         if any { $_[0]->{architecture} eq $architecture }, @{$facts->{pkg}->{$dep->{package}}};
 230                     1;
 231                 });
 232             }
 233
 234             # We add every sub-dependencies as we cannot know which package
 235             # in an OR dependency has been effectively used.
 236             deps_iterate($new_deps, sub {
 237                 push @unprocessed_pkgs,
 238                      $_[0]->{package} . (defined $_[0]->{archqual} ? ':' . $_[0]->{archqual} : '');
 239                 1
 240             });
 241         } elsif (defined $facts->{virtualpkg}->{$pkg_name}) {
 242             # virtual package: we cannot know for sure which implementation
 243             # is the one that has been used, so let's add them all...
 244             foreach my $provided (@{$facts->{virtualpkg}->{$pkg_name}}) {
 245                 push @unprocessed_pkgs, $provided->{provider};
 246             }
 247         }
 248         # else: it is a package in an OR dependency that has been otherwise
 249         # satisfied.
 250     }
 251     $installed_deps->simplify_deps(Dpkg::Deps::KnownFacts->new());
 252     $installed_deps->sort();
 253     $installed_deps = "\n" . $installed_deps->output();
 254     $installed_deps =~ s/, /,\n/g;
 255
 256     return $installed_deps;
 257 }
 258
 259 sub is_cross_executable {
 260     my $host_arch = get_host_arch();
 261     my $build_arch = get_build_arch();
 262
 263     return if $host_arch eq $build_arch;
 264
 265     # If we are cross-compiling, record whether it was possible to execute
 266     # the host architecture by cross-compiling and executing a small
 267     # host-arch binary.
 268     my $CC = debarch_to_gnutriplet($host_arch) . '-gcc';
 269
 270     # If we do not have a cross-compiler, we might be in the process of
 271     # building one or cross-compiling using a language other than C/C++,
 272     # and aborting the build is then not very useful.
 273     return if ! find_command($CC);
 274
 275     my $crossprog = <<~'CROSSPROG';
 276         #include <unistd.h>
 277         int main() { write(1, "ok", 2); return 0; }
 278     CROSSPROG
 279     my ($stdout, $stderr) = ('', '');
 280     my $tmpfh = File::Temp->new();
 281     spawn(
 282         exec => [ $CC, '-w', '-x', 'c', '-o', $tmpfh->filename, '-' ],
 283         from_string => \$crossprog,
 284         to_string => \$stdout,
 285         error_to_string => \$stderr,
 286         wait_child => 1,
 287         nocheck => 1,
 288     );
 289     if ($?) {
 290         print { *STDOUT } $stdout;
 291         print { *STDERR } $stderr;
 292         eval {
 293             subprocerr("$CC -w -x c -");
 294         };
 295         warning($@);
 296         return;
 297     }
 298     close $tmpfh;
 299     spawn(
 300         exec => [ $tmpfh->filename ],
 301         error_to_file => '/dev/null',
 302         to_string => \$stdout,
 303         wait_child => 1,
 304         nocheck => 1,
 305     );
 306
 307     return 1 if $? == 0 && $stdout eq 'ok';
 308     return 0;
 309 }
 310
 311 sub get_build_tainted_by {
 312     my @tainted = run_vendor_hook('build-tainted-by');
 313
 314     if (is_cross_executable()) {
 315         push @tainted, 'can-execute-cross-built-programs';
 316     }
 317
 318     return @tainted;
 319 }
 320
 321 sub cleansed_environment {
 322     # Consider only allowed variables which are not supposed to leak
 323     # local user information.
 324     my %env = map {
 325         $_ => $ENV{$_}
 326     } grep {
 327         exists $ENV{$_}
 328     } get_build_env_allowed();
 329
 330     # Record flags from dpkg-buildflags.
 331     my $bf = Dpkg::BuildFlags->new();
 332     $bf->load_system_config();
 333     $bf->load_user_config();
 334     $bf->load_environment_config();
 335     foreach my $flag ($bf->list()) {
 336         next if $bf->get_origin($flag) eq 'vendor';
 337
 338         # We do not need to record *_{STRIP,APPEND,PREPEND} as they
 339         # have been used already to compute the above value.
 340         $env{"DEB_${flag}_SET"} = $bf->get($flag);
 341     }
 342
 343     return join "\n", map { $_ . '="' . ($env{$_} =~ s/"/\\"/gr) . '"' }
 344                       sort keys %env;
 345 }
 346
 347 sub version {
 348     printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
 349
 350     printf g_('
 351 This is free software; see the GNU General Public License version 2 or
 352 later for copying conditions. There is NO warranty.
 353 ');
 354 }
 355
 356 sub usage {
 357     printf g_(
 358 'Usage: %s [<option>...]')
 359     . "\n\n" . g_(
 360 "Options:
 361   --build=<type>[,...]     specify the build <type>: full, source, binary,
 362                              any, all (default is \'full\').
 363   -c<control-file>         get control info from this file.
 364   -l<changelog-file>       get per-version info from this file.
 365   -f<files-list-file>      get .deb files list from this file.
 366   -F<changelog-format>     force changelog format.
 367   -O[<buildinfo-file>]     write to stdout (or <buildinfo-file>).
 368   -u<upload-files-dir>     directory with files (default is '..').
 369   --always-include-kernel  always include Build-Kernel-Version.
 370   --always-include-path    always include Build-Path.
 371   --admindir=<directory>   change the administrative directory.
 372   -?, --help               show this help message.
 373       --version            show the version.
 374 "), $Dpkg::PROGNAME;
 375 }
 376
 377 my $build_opts = Dpkg::BuildOptions->new();
 378 $build_opts->parse_features('buildinfo', \%use_feature);
 379
 380 while (@ARGV) {
 381     $_ = shift @ARGV ;
 382     if (m/^--build=(.*)$/) {
 383         set_build_type_from_options($1, $_);
 384     } elsif (m/^-c(.*)$/) {
 385         $controlfile = $1;
 386     } elsif (m/^-l(.*)$/) {
 387         $changelogfile = $1;
 388     } elsif (m/^-f(.*)$/) {
 389         $fileslistfile = $1;
 390     } elsif (m/^-F([0-9a-z]+)$/) {
 391         $changelogformat = $1;
 392     } elsif (m/^-u(.*)$/) {
 393         $uploadfilesdir = $1;
 394     } elsif (m/^-O$/) {
 395         $stdout = 1;
 396     } elsif (m/^-O(.*)$/) {
 397         $outputfile = $1;
 398     } elsif (m/^(--buildinfo-id)=.*$/) {
 399         # Deprecated option
 400         warning(g_('%s is deprecated; it is without effect'), $1);
 401     } elsif (m/^--always-include-kernel$/) {
 402         $use_feature{kernel} = 1;
 403     } elsif (m/^--always-include-path$/) {
 404         $use_feature{path} = 1;
 405     } elsif (m/^--admindir=(.*)$/) {
 406         $admindir = $1;
 407     } elsif (m/^-(?:\?|-help)$/) {
 408         usage();
 409         exit(0);
 410     } elsif (m/^--version$/) {
 411         version();
 412         exit(0);
 413     } else {
 414         usageerr(g_("unknown option '%s'"), $_);
 415     }
 416 }
 417
 418 my $control = Dpkg::Control::Info->new($controlfile);
 419 my $fields = Dpkg::Control->new(type => CTRL_FILE_BUILDINFO);
 420 my $dist = Dpkg::Dist::Files->new();
 421
 422 # Retrieve info from the current changelog entry.
 423 my %options = (file => $changelogfile);
 424 $options{changelogformat} = $changelogformat if $changelogformat;
 425 my $changelog = changelog_parse(%options);
 426
 427 # Retrieve info from the former changelog entry to handle binNMUs.
 428 $options{count} = 1;
 429 $options{offset} = 1;
 430 my $prev_changelog = changelog_parse(%options);
 431
 432 my $sourceversion = Dpkg::Version->new($changelog->{'Binary-Only'} ?
 433                     $prev_changelog->{'Version'} : $changelog->{'Version'});
 434 my $binaryversion = Dpkg::Version->new($changelog->{'Version'});
 435
 436 # Include .dsc if available.
 437 my $spackage = $changelog->{'Source'};
 438 my $sversion = $sourceversion->as_string(omit_epoch => 1);
 439
 440 if (build_has_any(BUILD_SOURCE)) {
 441     my $dsc = "${spackage}_${sversion}.dsc";
 442
 443     $checksums->add_from_file("$uploadfilesdir/$dsc", key => $dsc);
 444
 445     push @archvalues, 'source';
 446 }
 447
 448 my $dist_count = 0;
 449
 450 $dist_count = $dist->load($fileslistfile) if -e $fileslistfile;
 451
 452 if (build_has_any(BUILD_BINARY)) {
 453     error(g_('binary build with no binary artifacts found; .buildinfo is meaningless'))
 454         if $dist_count == 0;
 455
 456     foreach my $file ($dist->get_files()) {
 457         # Make us a bit idempotent.
 458         next if $file->{filename} =~ m/\.buildinfo$/;
 459
 460         if (defined $file->{arch}) {
 461             my $arch_all = debarch_eq('all', $file->{arch});
 462
 463             next if build_has_none(BUILD_ARCH_INDEP) and $arch_all;
 464             next if build_has_none(BUILD_ARCH_DEP) and not $arch_all;
 465
 466             $distbinaries{$file->{package}} = 1 if defined $file->{package};
 467         }
 468
 469         my $path = "$uploadfilesdir/$file->{filename}";
 470         $checksums->add_from_file($path, key => $file->{filename});
 471
 472         if (defined $file->{package_type} and $file->{package_type} =~ m/^u?deb$/) {
 473             push @archvalues, $file->{arch}
 474                 if defined $file->{arch} and not $archadded{$file->{arch}}++;
 475         }
 476     }
 477 }
 478
 479 $fields->{'Format'} = $buildinfo_format;
 480 $fields->{'Source'} = $spackage;
 481 $fields->{'Binary'} = join(' ', sort keys %distbinaries);
 482 # Avoid overly long line by splitting over multiple lines.
 483 if (length($fields->{'Binary'}) > 980) {
 484     $fields->{'Binary'} =~ s/(.{0,980}) /$1\n/g;
 485 }
 486
 487 $fields->{'Architecture'} = join ' ', sort @archvalues;
 488 $fields->{'Version'} = $binaryversion;
 489
 490 if ($changelog->{'Binary-Only'}) {
 491     $fields->{'Source'} .= ' (' . $sourceversion . ')';
 492     $fields->{'Binary-Only-Changes'} =
 493         $changelog->{'Changes'} . "\n\n"
 494         . ' -- ' . $changelog->{'Maintainer'}
 495         . '  ' . $changelog->{'Date'};
 496 }
 497
 498 $fields->{'Build-Origin'} = get_current_vendor();
 499 $fields->{'Build-Architecture'} = get_build_arch();
 500 $fields->{'Build-Date'} = get_build_date();
 501
 502 if ($use_feature{kernel}) {
 503     my ($kern_rel, $kern_ver);
 504
 505     ((undef) x 2, $kern_rel, $kern_ver, undef) = POSIX::uname();
 506     $fields->{'Build-Kernel-Version'} = "$kern_rel $kern_ver";
 507 }
 508
 509 my $cwd = getcwd();
 510 if ($use_feature{path}) {
 511     $fields->{'Build-Path'} = $cwd;
 512 } else {
 513     # Only include the build path if its root path is considered acceptable
 514     # by the vendor.
 515     foreach my $root_path (run_vendor_hook('builtin-system-build-paths')) {
 516         if (index($cwd, $root_path) == 0) {
 517             $fields->{'Build-Path'} = $cwd;
 518             last;
 519         }
 520     }
 521 }
 522
 523 $fields->{'Build-Tainted-By'} = "\n" . join "\n", get_build_tainted_by();
 524
 525 $checksums->export_to_control($fields);
 526
 527 $fields->{'Installed-Build-Depends'} = collect_installed_builddeps($control);
 528
 529 $fields->{'Environment'} = "\n" . cleansed_environment();
 530
 531 # Generate the buildinfo filename.
 532 if ($stdout) {
 533     # Nothing to do.
 534 } elsif (defined $outputfile) {
 535     $buildinfo = basename($outputfile);
 536 } else {
 537     my $arch;
 538
 539     if (build_has_any(BUILD_ARCH_DEP)) {
 540         $arch = get_host_arch();
 541     } elsif (build_has_any(BUILD_ARCH_INDEP)) {
 542         $arch = 'all';
 543     } elsif (build_has_any(BUILD_SOURCE)) {
 544         $arch = 'source';
 545     }
 546
 547     my $bversion = $binaryversion->as_string(omit_epoch => 1);
 548     $buildinfo = "${spackage}_${bversion}_${arch}.buildinfo";
 549     $outputfile = "$uploadfilesdir/$buildinfo";
 550 }
 551
 552 # Write out the generated .buildinfo file.
 553
 554 if ($stdout) {
 555     $fields->output(\*STDOUT);
 556 } else {
 557     my $section = $control->get_source->{'Section'} || '-';
 558     my $priority = $control->get_source->{'Priority'} || '-';
 559
 560     # Obtain a lock on debian/control to avoid simultaneous updates
 561     # of debian/files when parallel building is in use
 562     my $lockfh;
 563     my $lockfile = 'debian/control';
 564     $lockfile = $controlfile if not -e $lockfile;
 565
 566     sysopen $lockfh, $lockfile, O_WRONLY
 567         or syserr(g_('cannot write %s'), $lockfile);
 568     file_lock($lockfh, $lockfile);
 569
 570     $dist = Dpkg::Dist::Files->new();
 571     $dist->load($fileslistfile) if -e $fileslistfile;
 572
 573     foreach my $file ($dist->get_files()) {
 574         if (defined $file->{package} &&
 575             $file->{package} eq $spackage &&
 576             $file->{package_type} eq 'buildinfo' &&
 577             (debarch_eq($file->{arch}, $fields->{'Architecture'}) ||
 578              debarch_eq($file->{arch}, 'all') ||
 579              debarch_eq($file->{arch}, 'source'))) {
 580             $dist->del_file($file->{filename});
 581         }
 582     }
 583
 584     $dist->add_file($buildinfo, $section, $priority);
 585     $dist->save("$fileslistfile.new");
 586
 587     rename "$fileslistfile.new", $fileslistfile
 588         or syserr(g_('install new files list file'));
 589
 590     # Release the lock
 591     close $lockfh or syserr(g_('cannot close %s'), $lockfile);
 592
 593     $fields->save("$outputfile.new");
 594
 595     rename "$outputfile.new", $outputfile
 596         or syserr(g_("cannot install output buildinfo file '%s'"), $outputfile);
 597 }