debian/dpkg-checkbuild

   1 #!/usr/bin/perl -w
   2 # GPL copyright 2001 by Joey Hess <joeyh@debian.org>
   3
   4 use strict;
   5 use Getopt::Long;
   6
   7 sub usage {
   8         print STDERR <<EOF;
   9 Usage: dpkg-checkbuild [-B] [control-file]
  10         -B              binary-only, ignore -Indep
  11         control-file    control file to process [Default: debian/control]
  12 EOF
  13 }
  14
  15 my ($me)=$0=~m:.*/(.+):;
  16
  17 my $binary_only=0;
  18 if (! GetOptions('-B' => \$binary_only)) {
  19         usage();
  20         exit(2);
  21 }
  22 my $control=shift || "debian/control";
  23
  24 open (CONTROL, $control) || die "$control: $!\n";
  25 my @status=parse_status();
  26 my (@unmet, @conflicts);
  27 while (<CONTROL>) {
  28         chomp;
  29         last if $_ eq ''; # end of first stanza
  30
  31         if (/^Build-Depends:\s+(.*)/i) {
  32                 push @unmet, build_depends($1, @status);
  33         }
  34         elsif (/^Build-Conflicts:\s+(.*)/i) {
  35                 push @conflicts, build_conflicts($1, @status);
  36         }
  37         elsif (! $binary_only && /^Build-Depends-Indep:\s+(.*)/i) {
  38                 push @unmet, build_depends($1, @status);
  39         }
  40         elsif (! $binary_only && /^Build-Conflicts-Indep:\s+(.*)/i) {
  41                 push @conflicts, build_conflicts($1, @status);
  42         }
  43 }
  44 close CONTROL;
  45
  46 if (@unmet) {
  47         print STDERR "$me: Unmet build dependancies: ";
  48         print STDERR join(", ", @unmet), "\n";
  49 }
  50 if (@conflicts) {
  51         print STDERR "$me: Build conflicts: ";
  52         print STDERR join(", ", @conflicts), "\n";
  53 }
  54 exit 1 if @unmet || @conflicts;
  55
  56 # This part could be replaced. Silly little status file parser.
  57 # thanks to Matt Zimmerman. Returns two hash references that
  58 # are exactly what the other functions need...
  59 sub parse_status {
  60         my $status=shift || "/var/lib/dpkg/status";
  61
  62         my %providers;
  63         my %version;
  64         local $/ = '';
  65         open(STATUS, "<$status") || die "$status: $!\n";
  66         while (<STATUS>) {
  67                 next unless /^Status: .*ok installed$/m;
  68
  69                 my ($package) = /^Package: (.*)$/m;
  70                 push @{$providers{$package}}, $package;
  71                 ($version{$package}) = /^Version: (.*)$/m;
  72
  73                 if (/^Provides: (.*)$/m) {
  74                         foreach (split(/,\s+/, $1)) {
  75                                 push @{$providers{$_}}, $package;
  76                         }
  77                 }
  78         }
  79         close STATUS;
  80
  81         return \%version, \%providers;
  82 }
  83
  84 # This function checks the build dependancies passed in as the first
  85 # parameter. If they are satisfied, returns false. If they are unsatisfied,
  86 # an list of the unsatisfied depends is returned.
  87 #
  88 # Additional parameters that must be passed:
  89 # * A reference to a hash of all "ok installed" the packages on the system,
  90 #   with the hash key being the package name, and the value being the
  91 #   installed version.
  92 # * A reference to a hash, where the keys are package names, and the
  93 #   value is a true value iff some package installed on the system provides
  94 #   that package (all installed packages provide themselves)
  95 #
  96 # Optionally, the architecture the package is to be built for can be passed
  97 # in as the 4th parameter. If not set, dpkg will be queried for the build
  98 # architecture.
  99 sub build_depends {
 100         return check_line(1, @_);
 101 }
 102
 103 # This function is exactly like unmet_build_depends, except it
 104 # checks for build conflicts, and returns a list of the packages
 105 # that are installed and are conflicted with.
 106 sub build_conflicts {
 107         return check_line(0, @_);
 108 }
 109
 110 # This function does all the work. The first parameter is 1 to check build
 111 # deps, and 0 to check build conflicts.
 112 sub check_line {
 113         my $build_depends=shift;
 114         my $line=shift;
 115         my %version=%{shift()};
 116         my %providers=%{shift()};
 117         my $build_arch=shift || `dpkg --print-architecture`;
 118         chomp $build_arch;
 119
 120         my @unmet=();
 121         foreach my $dep (split(/,\s+/, $line)) {
 122                 my $ok=0;
 123                 my @possibles=();
 124 ALTERNATE:      foreach my $alternate (split(/\s*\|\s*/, $dep)) {
 125                         my ($package, $rest)=split(/\s+/, $alternate, 2);
 126
 127                         # Check arch specifications.
 128                         if (defined $rest && $rest=~m/\[(.*?)\]/) {
 129                                 my $arches=lc($1);
 130                                 my $seen_arch='';
 131                                 foreach my $arch (split(' ', $arches)) {
 132                                         if ($arch eq $build_arch) {
 133                                                 $seen_arch=1;
 134                                                 next;
 135                                         }
 136                                         elsif ($arch eq "!$build_arch") {
 137                                                 next ALTERNATE;
 138                                         }
 139                                         elsif ($arch =~ /!/) {
 140                                                 # This is equivilant to
 141                                                 # having seen the current arch,
 142                                                 # unless the current arch
 143                                                 # is also listed..
 144                                                 $seen_arch=1;
 145                                         }
 146                                 }
 147                                 if (! $seen_arch) {
 148                                         next;
 149                                 }
 150                         }
 151
 152                         # This is a possibile way to meet the dependancy.
 153                         # Remove the arch stuff from $alternate.
 154                         $alternate=~s/\s+\[.*?\]//;
 155                         push @possibles, $alternate;
 156
 157                         # Check version.
 158                         if (defined $rest && $rest=~m/\((..)\s+(.*?)\)/) {
 159                                 my $relation=$1;
 160                                 my $version=$2;
 161
 162                                 if (! exists $version{$package}) {
 163                                         # Not installed at all, so fail.
 164                                         next;
 165                                 }
 166                                 else {
 167                                         # Compare installed and needed
 168                                         # version number.
 169                                         system("dpkg", "--compare-versions",
 170                                                 $version{$package}, $relation,
 171                                                  $version);
 172                                         if (($? >> 8) != 0) {
 173                                                 next; # fail
 174                                         }
 175                                 }
 176                         }
 177                         elsif (! defined $providers{$package}) {
 178                                 # It's not a versioned dependancy, and
 179                                 # nothing provides it, so fail.
 180                                 next;
 181                         }
 182
 183                         # If we get to here, the dependancy was met.
 184                         $ok=1;
 185                 }
 186
 187                 if (@possibles && (($build_depends && ! $ok) ||
 188                                    (! $build_depends && $ok))) {
 189                         # TODO: this could return a more complex
 190                         # data structure instead to save re-parsing.
 191                         push @unmet, join (" | ", @possibles);
 192                 }
 193         }
 194
 195         return @unmet;
 196 }