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