chiark - git - mdw - dpkg/blob - 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 Cwd;
  29 use File::Basename;
  30 use POSIX qw(:fcntl_h :locale_h strftime);
  31
  32 use Dpkg ();
  33 use Dpkg::Gettext;
  34 use Dpkg::Checksums;
  35 use Dpkg::ErrorHandling;
  36 use Dpkg::Arch qw(get_build_arch get_host_arch debarch_eq);
  37 use Dpkg::Build::Types;
  38 use Dpkg::Build::Info qw(get_build_env_whitelist);
  39 use Dpkg::BuildOptions;
  40 use Dpkg::BuildFlags;
  41 use Dpkg::BuildProfiles qw(get_build_profiles);
  42 use Dpkg::Control::Info;
  43 use Dpkg::Control::Fields;
  44 use Dpkg::Control;
  45 use Dpkg::Changelog::Parse;
  46 use Dpkg::Deps;
  47 use Dpkg::Dist::Files;
  48 use Dpkg::Util qw(:list);
  49 use Dpkg::File;
  50 use Dpkg::Version;
  51 use Dpkg::Vendor qw(get_current_vendor run_vendor_hook);
  52
  53 textdomain('dpkg-dev');
  54
  55 my $controlfile = 'debian/control';
  56 my $changelogfile = 'debian/changelog';
  57 my $changelogformat;
  58 my $fileslistfile = 'debian/files';
  59 my $uploadfilesdir = '..';
  60 my $outputfile;
  61 my $stdout = 0;
  62 my $admindir = $Dpkg::ADMINDIR;
  63 my %use_feature = (
  64     path => 0,
  65 );
  66 my @build_profiles = get_build_profiles();
  67 my $buildinfo_format = '1.0';
  68 my $buildinfo;
  69
  70 my $checksums = Dpkg::Checksums->new();
  71 my %archadded;
  72 my @archvalues;
  73
  74 sub get_build_date {
  75     my $date;
  76
  77     setlocale(LC_TIME, 'C');
  78     $date = strftime('%a, %d %b %Y %T %z', localtime);
  79     setlocale(LC_TIME, '');
  80
  81     return $date;
  82 }
  83
  84 # There is almost the same function in dpkg-checkbuilddeps, they probably
  85 # should be factored out.
  86 sub parse_status {
  87     my $status = shift;
  88
  89     my $facts = Dpkg::Deps::KnownFacts->new();
  90     my %depends;
  91     my @essential_pkgs;
  92
  93     local $/ = '';
  94     open my $status_fh, '<', $status or syserr(g_('cannot open %s'), $status);
  95     while (<$status_fh>) {
  96         next unless /^Status: .*ok installed$/m;
  97
  98         my ($package) = /^Package: (.*)$/m;
  99         my ($version) = /^Version: (.*)$/m;
 100         my ($arch) = /^Architecture: (.*)$/m;
 101         my ($multiarch) = /^Multi-Arch: (.*)$/m;
 102
 103         $facts->add_installed_package($package, $version, $arch, $multiarch);
 104
 105         if (/^Essential: yes$/m) {
 106             push @essential_pkgs, $package;
 107         }
 108
 109         if (/^Provides: (.*)$/m) {
 110             my $provides = deps_parse($1, reduce_arch => 1, union => 1);
 111
 112             next if not defined $provides;
 113
 114             deps_iterate($provides, sub {
 115                 my $dep = shift;
 116                 $facts->add_provided_package($dep->{package}, $dep->{relation},
 117                                              $dep->{version}, $package);
 118             });
 119         }
 120
 121         foreach my $deptype (qw(Pre-Depends Depends)) {
 122             next unless /^$deptype: (.*)$/m;
 123
 124             my $depends = $1;
 125             foreach (split /,\s*/, $depends) {
 126                 push @{$depends{"$package:$arch"}}, $_;
 127             }
 128         }
 129     }
 130     close $status_fh;
 131
 132     return ($facts, \%depends, \@essential_pkgs);
 133 }
 134
 135 sub append_deps {
 136     my $pkgs = shift;
 137
 138     foreach my $dep_str (@_) {
 139         next unless $dep_str;
 140
 141         my $deps = deps_parse($dep_str, reduce_restrictions => 1,
 142                               build_dep => 1,
 143                               build_profiles => \@build_profiles);
 144
 145         # We add every sub-dependencies as we cannot know which package in
 146         # an OR dependency has been effectively used.
 147         deps_iterate($deps, sub {
 148             push @{$pkgs},
 149                 $_[0]->{package} . (defined $_[0]->{archqual} ? ':' . $_[0]->{archqual} : '');
 150             1
 151         });
 152     }
 153 }
 154
 155 sub collect_installed_builddeps {
 156     my $control = shift;
 157
 158     my ($facts, $depends, $essential_pkgs) = parse_status("$admindir/status");
 159     my %seen_pkgs;
 160     my @unprocessed_pkgs;
 161
 162     # Parse essential packages list.
 163     append_deps(\@unprocessed_pkgs,
 164                 @{$essential_pkgs},
 165                 run_vendor_hook('builtin-build-depends'),
 166                 $control->get_source->{'Build-Depends'});
 167
 168     if (build_has_any(BUILD_ARCH_DEP)) {
 169         append_deps(\@unprocessed_pkgs,
 170                     $control->get_source->{'Build-Depends-Arch'});
 171     }
 172
 173     if (build_has_any(BUILD_ARCH_INDEP)) {
 174         append_deps(\@unprocessed_pkgs,
 175                     $control->get_source->{'Build-Depends-Indep'});
 176     }
 177
 178     my $installed_deps = Dpkg::Deps::AND->new();
 179
 180     while (my $pkg_name = shift @unprocessed_pkgs) {
 181         next if $seen_pkgs{$pkg_name};
 182         $seen_pkgs{$pkg_name} = 1;
 183
 184         my $required_architecture;
 185         if ($pkg_name =~ /\A(.*):(.*)\z/) {
 186             $pkg_name = $1;
 187             my $arch = $2;
 188             $required_architecture = $arch if $arch !~ /\A(?:all|any|native)\Z/
 189         }
 190         my $pkg;
 191         my $qualified_pkg_name;
 192         foreach my $installed_pkg (@{$facts->{pkg}->{$pkg_name}}) {
 193             if (!defined $required_architecture ||
 194                 $required_architecture eq $installed_pkg->{architecture}) {
 195                 $pkg = $installed_pkg;
 196                 $qualified_pkg_name = $pkg_name . ':' . $installed_pkg->{architecture};
 197                 last;
 198             }
 199         }
 200         if (defined $pkg) {
 201             my $version = $pkg->{version};
 202             my $architecture = $pkg->{architecture};
 203             my $new_deps_str = defined $depends->{$qualified_pkg_name} ? deps_concat(@{$depends->{$qualified_pkg_name}}) : '';
 204             my $new_deps = deps_parse($new_deps_str);
 205             if (!defined $required_architecture) {
 206                 $installed_deps->add(Dpkg::Deps::Simple->new("$pkg_name (= $version)"));
 207             } else {
 208                 $installed_deps->add(Dpkg::Deps::Simple->new("$qualified_pkg_name (= $version)"));
 209
 210                 # Dependencies of foreign packages are also foreign packages
 211                 # (or Arch:all) so we need to qualify them as well. We figure
 212                 # out if the package is actually foreign by searching for an
 213                 # installed package of the right architecture.
 214                 deps_iterate($new_deps, sub {
 215                     my $dep = shift;
 216                     return unless defined $facts->{pkg}->{$dep->{package}};
 217                     $dep->{archqual} //= $architecture
 218                         if any { $_[0]->{architecture} eq $architecture }, @{$facts->{pkg}->{$dep->{package}}};
 219                     1;
 220                 });
 221             }
 222
 223             # We add every sub-dependencies as we cannot know which package
 224             # in an OR dependency has been effectively used.
 225             deps_iterate($new_deps, sub {
 226                 push @unprocessed_pkgs,
 227                      $_[0]->{package} . (defined $_[0]->{archqual} ? ':' . $_[0]->{archqual} : '');
 228                 1
 229             });
 230         } elsif (defined $facts->{virtualpkg}->{$pkg_name}) {
 231             # virtual package: we cannot know for sure which implementation
 232             # is the one that has been used, so let's add them all...
 233             foreach my $provided (@{$facts->{virtualpkg}->{$pkg_name}}) {
 234                 my ($provided_by, $provided_rel, $provided_ver) = @{$provided};
 235                 push @unprocessed_pkgs, $provided_by;
 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
 249 sub 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
 275 sub version {
 276     printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
 277
 278     printf g_('
 279 This is free software; see the GNU General Public License version 2 or
 280 later for copying conditions. There is NO warranty.
 281 ');
 282 }
 283
 284 sub 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-path    always include Build-Path.
 298   --admindir=<directory>   change the administrative directory.
 299   -?, --help               show this help message.
 300       --version            show the version.
 301 "), $Dpkg::PROGNAME;
 302 }
 303
 304 my $build_opts = Dpkg::BuildOptions->new();
 305 $build_opts->parse_features('buildinfo', \%use_feature);
 306
 307 while (@ARGV) {
 308     $_ = shift @ARGV ;
 309     if (m/^--build=(.*)$/) {
 310         set_build_type_from_options($1, $_);
 311     } elsif (m/^-c(.*)$/) {
 312         $controlfile = $1;
 313     } elsif (m/^-l(.*)$/) {
 314         $changelogfile = $1;
 315     } elsif (m/^-f(.*)$/) {
 316         $fileslistfile = $1;
 317     } elsif (m/^-F([0-9a-z]+)$/) {
 318         $changelogformat = $1;
 319     } elsif (m/^-u(.*)$/) {
 320         $uploadfilesdir = $1;
 321     } elsif (m/^-O$/) {
 322         $stdout = 1;
 323     } elsif (m/^-O(.*)$/) {
 324         $outputfile = $1;
 325     } elsif (m/^--buildinfo-id=.*$/) {
 326         # Deprecated option
 327         warning('--buildinfo-id is deprecated, it is without effect');
 328     } elsif (m/^--always-include-path$/) {
 329         $use_feature{path} = 1;
 330     } elsif (m/^--admindir=(.*)$/) {
 331         $admindir = $1;
 332     } elsif (m/^-(?:\?|-help)$/) {
 333         usage();
 334         exit(0);
 335     } elsif (m/^--version$/) {
 336         version();
 337         exit(0);
 338     } else {
 339         usageerr(g_("unknown option '%s'"), $_);
 340     }
 341 }
 342
 343 my $control = Dpkg::Control::Info->new($controlfile);
 344 my $fields = Dpkg::Control->new(type => CTRL_FILE_BUILDINFO);
 345 my $dist = Dpkg::Dist::Files->new();
 346
 347 # Retrieve info from the current changelog entry.
 348 my %options = (file => $changelogfile);
 349 $options{changelogformat} = $changelogformat if $changelogformat;
 350 my $changelog = changelog_parse(%options);
 351
 352 # Retrieve info from the former changelog entry to handle binNMUs.
 353 $options{count} = 1;
 354 $options{offset} = 1;
 355 my $prev_changelog = changelog_parse(%options);
 356
 357 my $sourceversion = $changelog->{'Binary-Only'} ?
 358                     $prev_changelog->{'Version'} : $changelog->{'Version'};
 359 my $binaryversion = Dpkg::Version->new($changelog->{'Version'});
 360
 361 # Include .dsc if available.
 362 my $spackage = $changelog->{'Source'};
 363 (my $sversion = $sourceversion) =~ s/^\d+://;
 364
 365 if (build_has_any(BUILD_SOURCE)) {
 366     my $dsc = "${spackage}_${sversion}.dsc";
 367
 368     $checksums->add_from_file("$uploadfilesdir/$dsc", key => $dsc);
 369
 370     push @archvalues, 'source';
 371 }
 372
 373 my $dist_count = 0;
 374
 375 $dist_count = $dist->load($fileslistfile) if -e $fileslistfile;
 376
 377 if (build_has_any(BUILD_BINARY)) {
 378     error(g_('binary build with no binary artifacts found; .buildinfo is meaningless'))
 379         if $dist_count == 0;
 380
 381     foreach my $file ($dist->get_files()) {
 382         # Make us a bit idempotent.
 383         next if $file->{filename} =~ m/\.buildinfo$/;
 384
 385         my $path = "$uploadfilesdir/$file->{filename}";
 386         $checksums->add_from_file($path, key => $file->{filename});
 387
 388         if (defined $file->{package_type} and $file->{package_type} =~ m/^u?deb$/) {
 389             push @archvalues, $file->{arch}
 390                 if defined $file->{arch} and not $archadded{$file->{arch}}++;
 391         }
 392     }
 393 }
 394
 395 $fields->{'Format'} = $buildinfo_format;
 396 $fields->{'Source'} = $spackage;
 397 $fields->{'Binary'} = join(' ', map { $_->{'Package'} } $control->get_packages());
 398 # Avoid overly long line by splitting over multiple lines.
 399 if (length($fields->{'Binary'}) > 980) {
 400     $fields->{'Binary'} =~ s/(.{0,980}) /$1\n/g;
 401 }
 402
 403 $fields->{'Architecture'} = join ' ', sort @archvalues;
 404 $fields->{'Version'} = $binaryversion;
 405
 406 if ($changelog->{'Binary-Only'}) {
 407     $fields->{'Source'} .= ' (' . $sourceversion . ')';
 408     $fields->{'Binary-Only-Changes'} =
 409         $changelog->{'Changes'} . "\n\n"
 410         . ' -- ' . $changelog->{'Maintainer'}
 411         . '  ' . $changelog->{'Date'};
 412 }
 413
 414 $fields->{'Build-Origin'} = get_current_vendor();
 415 $fields->{'Build-Architecture'} = get_build_arch();
 416 $fields->{'Build-Date'} = get_build_date();
 417
 418 my $cwd = cwd();
 419 if ($use_feature{path}) {
 420     $fields->{'Build-Path'} = $cwd;
 421 } else {
 422     # Only include the build path if its root path is considered acceptable
 423     # by the vendor.
 424     foreach my $root_path (run_vendor_hook('builtin-system-build-paths')) {
 425         if (index($cwd, $root_path) == 0) {
 426             $fields->{'Build-Path'} = $cwd;
 427             last;
 428         }
 429     }
 430 }
 431
 432 $checksums->export_to_control($fields);
 433
 434 $fields->{'Installed-Build-Depends'} = collect_installed_builddeps($control);
 435
 436 $fields->{'Environment'} = "\n" . cleansed_environment();
 437
 438 # Generate the buildinfo filename.
 439 if ($stdout) {
 440     # Nothing to do.
 441 } elsif (defined $outputfile) {
 442     $buildinfo = basename($outputfile);
 443 } else {
 444     my $arch;
 445
 446     if (build_has_any(BUILD_ARCH_DEP)) {
 447         $arch = get_host_arch();
 448     } elsif (build_has_any(BUILD_ARCH_INDEP)) {
 449         $arch = 'all';
 450     } elsif (build_has_any(BUILD_SOURCE)) {
 451         $arch = 'source';
 452     }
 453
 454     my $bversion = $binaryversion->as_string(omit_epoch => 1);
 455     $buildinfo = "${spackage}_${bversion}_${arch}.buildinfo";
 456     $outputfile = "$uploadfilesdir/$buildinfo";
 457 }
 458
 459 # Write out the generated .buildinfo file.
 460
 461 if ($stdout) {
 462     $fields->output(\*STDOUT);
 463 } else {
 464     my $section = $control->get_source->{'Section'} || '-';
 465     my $priority = $control->get_source->{'Priority'} || '-';
 466
 467     # Obtain a lock on debian/control to avoid simultaneous updates
 468     # of debian/files when parallel building is in use
 469     my $lockfh;
 470     my $lockfile = 'debian/control';
 471     $lockfile = $controlfile if not -e $lockfile;
 472
 473     sysopen $lockfh, $lockfile, O_WRONLY
 474         or syserr(g_('cannot write %s'), $lockfile);
 475     file_lock($lockfh, $lockfile);
 476
 477     $dist = Dpkg::Dist::Files->new();
 478     $dist->load($fileslistfile) if -e $fileslistfile;
 479
 480     foreach my $file ($dist->get_files()) {
 481         if (defined $file->{package} &&
 482             $file->{package} eq $spackage &&
 483             $file->{package_type} eq 'buildinfo' &&
 484             (debarch_eq($file->{arch}, $fields->{'Architecture'}) ||
 485              debarch_eq($file->{arch}, 'all') ||
 486              debarch_eq($file->{arch}, 'source'))) {
 487             $dist->del_file($file->{filename});
 488         }
 489     }
 490
 491     $dist->add_file($buildinfo, $section, $priority);
 492     $dist->save("$fileslistfile.new");
 493
 494     rename "$fileslistfile.new", $fileslistfile
 495         or syserr(g_('install new files list file'));
 496
 497     # Release the lock
 498     close $lockfh or syserr(g_('cannot close %s'), $lockfile);
 499
 500     $fields->save("$outputfile.new");
 501
 502     rename "$outputfile.new", $outputfile
 503         or syserr(g_("cannot install output buildinfo file '%s'"), $outputfile);
 504 }
 505
 506 1;