chiark - git - mdw - dpkg/blob - scripts/dpkg-scanpackages.pl

   1 #!/usr/bin/perl
   2 #
   3 # dpkg-scanpackages
   4 #
   5 # Copyright © 2006-2015 Guillem Jover <guillem@debian.org>
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 2 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  19
  20 use warnings;
  21 use strict;
  22
  23 use Getopt::Long qw(:config posix_default bundling no_ignorecase);
  24 use File::Find;
  25
  26 use Dpkg ();
  27 use Dpkg::Gettext;
  28 use Dpkg::ErrorHandling;
  29 use Dpkg::Util qw(:list);
  30 use Dpkg::Control;
  31 use Dpkg::Version;
  32 use Dpkg::Checksums;
  33 use Dpkg::Compression::FileHandle;
  34
  35 textdomain('dpkg-dev');
  36
  37 # Do not pollute STDOUT with info messages
  38 report_options(info_fh => \*STDERR);
  39
  40 my (@samemaint, @changedmaint);
  41 my @spuriousover;
  42 my %packages;
  43 my %overridden;
  44 my %hash;
  45
  46 my %options = (help            => sub { usage(); exit 0; },
  47                version         => sub { version(); exit 0; },
  48                type            => undef,
  49                arch            => undef,
  50                hash            => undef,
  51                multiversion    => 0,
  52                'extra-override'=> undef,
  53                medium          => undef,
  54               );
  55
  56 my @options_spec = (
  57     'help|?',
  58     'version',
  59     'type|t=s',
  60     'arch|a=s',
  61     'hash|h=s',
  62     'multiversion|m!',
  63     'extra-override|e=s',
  64     'medium|M=s',
  65 );
  66
  67 sub version {
  68     printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
  69 }
  70
  71 sub usage {
  72     printf g_(
  73 "Usage: %s [<option>...] <binary-path> [<override-file> [<path-prefix>]] > Packages
  74
  75 Options:
  76   -t, --type <type>        scan for <type> packages (default is 'deb').
  77   -a, --arch <arch>        architecture to scan for.
  78   -h, --hash <hash-list>   only generate hashes for the specified list.
  79   -m, --multiversion       allow multiple versions of a single package.
  80   -e, --extra-override <file>
  81                            use extra override file.
  82   -M, --medium <medium>    add X-Medium field for dselect multicd access method
  83   -?, --help               show this help message.
  84       --version            show the version.
  85 "), $Dpkg::PROGNAME;
  86 }
  87
  88 sub load_override
  89 {
  90     my $override = shift;
  91     my $comp_file = Dpkg::Compression::FileHandle->new(filename => $override);
  92
  93     while (<$comp_file>) {
  94         s/\#.*//;
  95         s/\s+$//;
  96         next unless $_;
  97
  98         my ($p, $priority, $section, $maintainer) = split(/\s+/, $_, 4);
  99
 100         if (not defined($packages{$p})) {
 101             push(@spuriousover, $p);
 102             next;
 103         }
 104
 105         for my $package (@{$packages{$p}}) {
 106             if ($maintainer) {
 107                 if ($maintainer =~ m/(.+?)\s*=\>\s*(.+)/) {
 108                     my $oldmaint = $1;
 109                     my $newmaint = $2;
 110                     my $debmaint = $$package{Maintainer};
 111                     if (none { $debmaint eq $_ } split m{\s*//\s*}, $oldmaint) {
 112                         push(@changedmaint,
 113                              sprintf(g_('  %s (package says %s, not %s)'),
 114                                      $p, $$package{Maintainer}, $oldmaint));
 115                     } else {
 116                         $$package{Maintainer} = $newmaint;
 117                     }
 118                 } elsif ($$package{Maintainer} eq $maintainer) {
 119                     push(@samemaint, "  $p ($maintainer)");
 120                 } else {
 121                     warning(g_('unconditional maintainer override for %s'), $p);
 122                     $$package{Maintainer} = $maintainer;
 123                 }
 124             }
 125             $$package{Priority} = $priority;
 126             $$package{Section} = $section;
 127         }
 128         $overridden{$p} = 1;
 129     }
 130
 131     close($comp_file);
 132 }
 133
 134 sub load_override_extra
 135 {
 136     my $extra_override = shift;
 137     my $comp_file = Dpkg::Compression::FileHandle->new(filename => $extra_override);
 138
 139     while (<$comp_file>) {
 140         s/\#.*//;
 141         s/\s+$//;
 142         next unless $_;
 143
 144         my ($p, $field, $value) = split(/\s+/, $_, 3);
 145
 146         next unless defined($packages{$p});
 147
 148         for my $package (@{$packages{$p}}) {
 149             $$package{$field} = $value;
 150         }
 151     }
 152
 153     close($comp_file);
 154 }
 155
 156 sub process_deb {
 157     my ($pathprefix, $fn) = @_;
 158
 159     my $fields = Dpkg::Control->new(type => CTRL_INDEX_PKG);
 160
 161     open my $output_fh, '-|', 'dpkg-deb', '-I', $fn, 'control'
 162         or syserr(g_('cannot fork for %s'), 'dpkg-deb');
 163     $fields->parse($output_fh, $fn)
 164         or error(g_("couldn't parse control information from %s"), $fn);
 165     close $output_fh;
 166     if ($?) {
 167         warning(g_("'dpkg-deb -I %s control' exited with %d, skipping package"),
 168                 $fn, $?);
 169         return;
 170     }
 171
 172     my $p = $fields->{'Package'};
 173     error(g_('no Package field in control file of %s'), $fn)
 174         if not defined $p;
 175
 176     if (defined($packages{$p}) and not $options{multiversion}) {
 177         foreach my $pkg (@{$packages{$p}}) {
 178             if (version_compare_relation($fields->{'Version'}, REL_GT,
 179                                          $pkg->{'Version'}))
 180             {
 181                 warning(g_('package %s (filename %s) is repeat but newer ' .
 182                            'version; used that one and ignored data from %s!'),
 183                         $p, $fn, $pkg->{Filename});
 184                 $packages{$p} = [];
 185             } else {
 186                 warning(g_('package %s (filename %s) is repeat; ' .
 187                            'ignored that one and using data from %s!'),
 188                         $p, $fn, $pkg->{Filename});
 189                 return;
 190             }
 191         }
 192     }
 193
 194     warning(g_('package %s (filename %s) has Filename field!'), $p, $fn)
 195         if defined($fields->{'Filename'});
 196     $fields->{'Filename'} = "$pathprefix$fn";
 197
 198     my $sums = Dpkg::Checksums->new();
 199     $sums->add_from_file($fn);
 200     foreach my $alg (checksums_get_list()) {
 201         next if %hash and not $hash{$alg};
 202
 203         if ($alg eq 'md5') {
 204             $fields->{'MD5sum'} = $sums->get_checksum($fn, $alg);
 205         } else {
 206             $fields->{$alg} = $sums->get_checksum($fn, $alg);
 207         }
 208     }
 209     $fields->{'Size'} = $sums->get_size($fn);
 210     $fields->{'X-Medium'} = $options{medium} if defined $options{medium};
 211
 212     push @{$packages{$p}}, $fields;
 213 }
 214
 215 {
 216     local $SIG{__WARN__} = sub { usageerr($_[0]) };
 217     GetOptions(\%options, @options_spec);
 218 }
 219
 220 if (not (@ARGV >= 1 and @ARGV <= 3)) {
 221     usageerr(g_('one to three arguments expected'));
 222 }
 223
 224 my $type = $options{type} // 'deb';
 225 my $arch = $options{arch};
 226 %hash = map { $_ => 1 } split /,/, $options{hash} // '';
 227
 228 foreach my $alg (keys %hash) {
 229     if (not checksums_is_supported($alg)) {
 230         usageerr(g_('unsupported checksum \'%s\''), $alg);
 231     }
 232 }
 233
 234 my ($binarypath, $override, $pathprefix) = @ARGV;
 235
 236 if (not -e $binarypath) {
 237     error(g_('binary path %s not found'), $binarypath);
 238 }
 239 if (defined $override and not -e $override) {
 240     error(g_('override file %s not found'), $override);
 241 }
 242
 243 $pathprefix //= '';
 244
 245 my $find_filter;
 246 if ($options{arch}) {
 247     $find_filter = qr/_(?:all|${arch})\.$type$/;
 248 } else {
 249     $find_filter = qr/\.$type$/;
 250 }
 251 my @archives;
 252 my $scan_archives = sub {
 253     push @archives, $File::Find::name if m/$find_filter/;
 254 };
 255
 256 find({ follow => 1, follow_skip => 2, wanted => $scan_archives}, $binarypath);
 257 foreach my $fn (@archives) {
 258     process_deb($pathprefix, $fn);
 259 }
 260
 261 load_override($override) if defined $override;
 262 load_override_extra($options{'extra-override'}) if defined $options{'extra-override'};
 263
 264 my @missingover=();
 265
 266 my $records_written = 0;
 267 for my $p (sort keys %packages) {
 268     if (defined($override) and not defined($overridden{$p})) {
 269         push @missingover, $p;
 270     }
 271     for my $package (sort { $a->{Version} cmp $b->{Version} } @{$packages{$p}}) {
 272          print("$package\n") or syserr(g_('failed when writing stdout'));
 273          $records_written++;
 274     }
 275 }
 276 close(STDOUT) or syserr(g_("couldn't close stdout"));
 277
 278 if (@changedmaint) {
 279     warning(g_('Packages in override file with incorrect old maintainer value:'));
 280     warning($_) foreach (@changedmaint);
 281 }
 282 if (@samemaint) {
 283     warning(g_('Packages specifying same maintainer as override file:'));
 284     warning($_) foreach (@samemaint);
 285 }
 286 if (@missingover) {
 287     warning(g_('Packages in archive but missing from override file:'));
 288     warning('  %s', join(' ', @missingover));
 289 }
 290 if (@spuriousover) {
 291     warning(g_('Packages in override file but not in archive:'));
 292     warning('  %s', join(' ', @spuriousover));
 293 }
 294
 295 info(g_('Wrote %s entries to output Packages file.'), $records_written);