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_values no_ignorecase);
  24 use List::Util qw(none);
  25 use File::Find;
  26
  27 use Dpkg ();
  28 use Dpkg::Gettext;
  29 use Dpkg::ErrorHandling;
  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 @multi_instances;
  42 my @spuriousover;
  43 my %packages;
  44 my %overridden;
  45 my @checksums;
  46
  47 my %options = (
  48     help            => sub { usage(); exit 0; },
  49     version         => sub { version(); exit 0; },
  50     type            => undef,
  51     arch            => undef,
  52     hash            => undef,
  53     multiversion    => 0,
  54     'extra-override' => undef,
  55     medium          => undef,
  56 );
  57
  58 my @options_spec = (
  59     'help|?',
  60     'version',
  61     'type|t=s',
  62     'arch|a=s',
  63     'hash|h=s',
  64     'multiversion|m!',
  65     'extra-override|e=s',
  66     'medium|M=s',
  67 );
  68
  69 sub version {
  70     printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
  71 }
  72
  73 sub usage {
  74     printf g_(
  75 "Usage: %s [<option>...] <binary-path> [<override-file> [<path-prefix>]] > Packages
  76
  77 Options:
  78   -t, --type <type>        scan for <type> packages (default is 'deb').
  79   -a, --arch <arch>        architecture to scan for.
  80   -h, --hash <hash-list>   only generate hashes for the specified list.
  81   -m, --multiversion       allow multiple versions of a single package.
  82   -e, --extra-override <file>
  83                            use extra override file.
  84   -M, --medium <medium>    add X-Medium field for dselect media access method
  85   -?, --help               show this help message.
  86       --version            show the version.
  87 "), $Dpkg::PROGNAME;
  88 }
  89
  90 sub load_override
  91 {
  92     my $override = shift;
  93     my $comp_file = Dpkg::Compression::FileHandle->new(filename => $override);
  94
  95     while (<$comp_file>) {
  96         s/\#.*//;
  97         s/\s+$//;
  98         next unless $_;
  99
 100         my ($p, $priority, $section, $maintainer) = split(/\s+/, $_, 4);
 101
 102         if (not defined($packages{$p})) {
 103             push(@spuriousover, $p);
 104             next;
 105         }
 106
 107         for my $package (@{$packages{$p}}) {
 108             if ($maintainer) {
 109                 if ($maintainer =~ m/(.+?)\s*=\>\s*(.+)/) {
 110                     my $oldmaint = $1;
 111                     my $newmaint = $2;
 112                     my $debmaint = $$package{Maintainer};
 113                     if (none { $debmaint eq $_ } split m{\s*//\s*}, $oldmaint) {
 114                         push(@changedmaint,
 115                              sprintf(g_('  %s (package says %s, not %s)'),
 116                                      $p, $$package{Maintainer}, $oldmaint));
 117                     } else {
 118                         $$package{Maintainer} = $newmaint;
 119                     }
 120                 } elsif ($$package{Maintainer} eq $maintainer) {
 121                     push(@samemaint, "  $p ($maintainer)");
 122                 } else {
 123                     warning(g_('unconditional maintainer override for %s'), $p);
 124                     $$package{Maintainer} = $maintainer;
 125                 }
 126             }
 127             $$package{Priority} = $priority;
 128             $$package{Section} = $section;
 129         }
 130         $overridden{$p} = 1;
 131     }
 132
 133     close($comp_file);
 134 }
 135
 136 sub load_override_extra
 137 {
 138     my $extra_override = shift;
 139     my $comp_file = Dpkg::Compression::FileHandle->new(filename => $extra_override);
 140
 141     while (<$comp_file>) {
 142         s/\#.*//;
 143         s/\s+$//;
 144         next unless $_;
 145
 146         my ($p, $field, $value) = split(/\s+/, $_, 3);
 147
 148         next unless defined($packages{$p});
 149
 150         for my $package (@{$packages{$p}}) {
 151             $$package{$field} = $value;
 152         }
 153     }
 154
 155     close($comp_file);
 156 }
 157
 158 sub process_deb {
 159     my ($pathprefix, $fn) = @_;
 160
 161     my $fields = Dpkg::Control->new(type => CTRL_INDEX_PKG);
 162
 163     open my $output_fh, '-|', 'dpkg-deb', '-I', $fn, 'control'
 164         or syserr(g_('cannot fork for %s'), 'dpkg-deb');
 165     $fields->parse($output_fh, $fn)
 166         or error(g_("couldn't parse control information from %s"), $fn);
 167     close $output_fh;
 168     if ($?) {
 169         warning(g_("'dpkg-deb -I %s control' exited with %d, skipping package"),
 170                 $fn, $?);
 171         return;
 172     }
 173
 174     my $p = $fields->{'Package'};
 175     error(g_('no Package field in control file of %s'), $fn)
 176         if not defined $p;
 177
 178     if (defined($packages{$p}) and not $options{multiversion}) {
 179         my $pkg = ${$packages{$p}}[0];
 180
 181         @multi_instances = ($pkg->{Filename}) if @multi_instances == 0;
 182         push @multi_instances, "$pathprefix$fn";
 183
 184         if (version_compare_relation($fields->{'Version'}, REL_GT,
 185                                      $pkg->{'Version'}))
 186         {
 187             warning(g_('package %s (filename %s) is repeat but newer ' .
 188                        'version; used that one and ignored data from %s!'),
 189                     $p, $fn, $pkg->{Filename});
 190             $packages{$p} = [];
 191         } else {
 192             warning(g_('package %s (filename %s) is repeat; ' .
 193                        'ignored that one and using data from %s!'),
 194                     $p, $fn, $pkg->{Filename});
 195             return;
 196         }
 197     }
 198
 199     warning(g_('package %s (filename %s) has Filename field!'), $p, $fn)
 200         if defined($fields->{'Filename'});
 201     $fields->{'Filename'} = "$pathprefix$fn";
 202
 203     my $sums = Dpkg::Checksums->new();
 204     $sums->add_from_file($fn, checksums => \@checksums);
 205     foreach my $alg (@checksums) {
 206         if ($alg eq 'md5') {
 207             $fields->{'MD5sum'} = $sums->get_checksum($fn, $alg);
 208         } else {
 209             $fields->{$alg} = $sums->get_checksum($fn, $alg);
 210         }
 211     }
 212     $fields->{'Size'} = $sums->get_size($fn);
 213     $fields->{'X-Medium'} = $options{medium} if defined $options{medium};
 214
 215     push @{$packages{$p}}, $fields;
 216 }
 217
 218 {
 219     local $SIG{__WARN__} = sub { usageerr($_[0]) };
 220     GetOptions(\%options, @options_spec);
 221 }
 222
 223 if (not 1 <= @ARGV <= 3) {
 224     usageerr(g_('one to three arguments expected'));
 225 }
 226
 227 my $type = $options{type} // 'deb';
 228 my $arch = $options{arch};
 229 my %hash = map { $_ => 1 } split /,/, $options{hash} // '';
 230
 231 foreach my $alg (keys %hash) {
 232     if (not checksums_is_supported($alg)) {
 233         usageerr(g_('unsupported checksum \'%s\''), $alg);
 234     }
 235 }
 236 @checksums = %hash ? keys %hash : checksums_get_list();
 237
 238 my ($binarypath, $override, $pathprefix) = @ARGV;
 239
 240 if (not -e $binarypath) {
 241     error(g_('binary path %s not found'), $binarypath);
 242 }
 243 if (defined $override and not -e $override) {
 244     error(g_('override file %s not found'), $override);
 245 }
 246
 247 $pathprefix //= '';
 248
 249 my $find_filter;
 250 if ($options{arch}) {
 251     $find_filter = qr/_(?:all|${arch})\.$type$/;
 252 } else {
 253     $find_filter = qr/\.$type$/;
 254 }
 255 my @archives;
 256 my $scan_archives = sub {
 257     push @archives, $File::Find::name if m/$find_filter/;
 258 };
 259
 260 find({ follow => 1, follow_skip => 2, wanted => $scan_archives}, $binarypath);
 261 foreach my $fn (@archives) {
 262     process_deb($pathprefix, $fn);
 263 }
 264
 265 load_override($override) if defined $override;
 266 load_override_extra($options{'extra-override'}) if defined $options{'extra-override'};
 267
 268 my @missingover = ();
 269
 270 my $records_written = 0;
 271 for my $p (sort keys %packages) {
 272     if (defined($override) and not defined($overridden{$p})) {
 273         push @missingover, $p;
 274     }
 275     for my $package (sort { $a->{Version} cmp $b->{Version} } @{$packages{$p}}) {
 276          print("$package\n") or syserr(g_('failed when writing stdout'));
 277          $records_written++;
 278     }
 279 }
 280 close(STDOUT) or syserr(g_("couldn't close stdout"));
 281
 282 if (@multi_instances) {
 283     warning(g_('Packages with multiple instances but no --multiversion specified:'));
 284     warning($_) foreach (sort @multi_instances);
 285 }
 286 if (@changedmaint) {
 287     warning(g_('Packages in override file with incorrect old maintainer value:'));
 288     warning($_) foreach (@changedmaint);
 289 }
 290 if (@samemaint) {
 291     warning(g_('Packages specifying same maintainer as override file:'));
 292     warning($_) foreach (@samemaint);
 293 }
 294 if (@missingover) {
 295     warning(g_('Packages in archive but missing from override file:'));
 296     warning('  %s', join(' ', @missingover));
 297 }
 298 if (@spuriousover) {
 299     warning(g_('Packages in override file but not in archive:'));
 300     warning('  %s', join(' ', @spuriousover));
 301 }
 302
 303 info(g_('Wrote %s entries to output Packages file.'), $records_written);