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

   1 #!/usr/bin/perl
   2 #
   3 # Copyright © 1999 Roderick Schertler
   4 # Copyright © 2002 Wichert Akkerman <wakkerma@debian.org>
   5 # Copyright © 2006-2009, 2011-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 (at
  10 # 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 strict;
  21 use warnings;
  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::Checksums;
  32 use Dpkg::Compression::FileHandle;
  33 use Dpkg::Compression;
  34
  35 textdomain('dpkg-dev');
  36
  37 # Hash of lists. The constants below describe what is in the lists.
  38 my %override;
  39 use constant {
  40     O_PRIORITY      => 0,
  41     O_SECTION       => 1,
  42     O_MAINT_FROM    => 2,   # undef for non-specific, else listref
  43     O_MAINT_TO      => 3,   # undef if there's no maint override
  44 };
  45
  46 my %extra_override;
  47
  48 my %priority = (
  49     'extra' => 1,
  50     'optional' => 2,
  51     'standard' => 3,
  52     'important' => 4,
  53     'required' => 5,
  54 );
  55
  56 # Switches
  57
  58 my $debug = 0;
  59 my $no_sort = 0;
  60 my $src_override = undef;
  61 my $extra_override_file = undef;
  62 my @sources;
  63
  64 my @option_spec = (
  65     'debug!' => \$debug,
  66     'help|?' => sub { usage(); exit 0; },
  67     'version' => sub { version(); exit 0; },
  68     'no-sort|n' => \$no_sort,
  69     'source-override|s=s' => \$src_override,
  70     'extra-override|e=s' => \$extra_override_file,
  71 );
  72
  73 sub version {
  74     printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
  75 }
  76
  77 sub usage {
  78     printf g_(
  79 "Usage: %s [<option>...] <binary-path> [<override-file> [<path-prefix>]] > Sources
  80
  81 Options:
  82   -n, --no-sort            don't sort by package before outputting.
  83   -e, --extra-override <file>
  84                            use extra override file.
  85   -s, --source-override <file>
  86                            use file for additional source overrides, default
  87                            is regular override file with .src appended.
  88       --debug              turn debugging on.
  89   -?, --help               show this help message.
  90       --version            show the version.
  91
  92 See the man page for the full documentation.
  93 "), $Dpkg::PROGNAME;
  94 }
  95
  96 sub load_override {
  97     my $file = shift;
  98     local $_;
  99
 100     my $comp_file = Dpkg::Compression::FileHandle->new(filename => $file);
 101     while (<$comp_file>) {
 102         s/#.*//;
 103         next if /^\s*$/;
 104         s/\s+$//;
 105
 106         my @data = split ' ', $_, 4;
 107         unless (@data == 3 || @data == 4) {
 108             warning(g_('invalid override entry at line %d (%d fields)'),
 109                     $., 0 + @data);
 110             next;
 111         }
 112         my ($package, $priority, $section, $maintainer) = @data;
 113         if (exists $override{$package}) {
 114             warning(g_('ignoring duplicate override entry for %s at line %d'),
 115                     $package, $.);
 116             next;
 117         }
 118         if (!$priority{$priority}) {
 119             warning(g_('ignoring override entry for %s, invalid priority %s'),
 120                     $package, $priority);
 121             next;
 122         }
 123
 124         $override{$package} = [];
 125         $override{$package}[O_PRIORITY] = $priority;
 126         $override{$package}[O_SECTION] = $section;
 127         if (!defined $maintainer) {
 128             # do nothing
 129         }
 130         elsif ($maintainer =~ /^(.*\S)\s*=>\s*(.*)$/) {
 131             $override{$package}[O_MAINT_FROM] = [split m{\s*//\s*}, $1];
 132             $override{$package}[O_MAINT_TO] = $2;
 133         }
 134         else {
 135             $override{$package}[O_MAINT_TO] = $maintainer;
 136         }
 137     }
 138     close($comp_file);
 139 }
 140
 141 sub load_src_override {
 142     my ($user_file, $regular_file) = @_;
 143     my ($file);
 144     local $_;
 145
 146     if (defined $user_file) {
 147         $file = $user_file;
 148     }
 149     elsif (defined $regular_file) {
 150         my $comp = compression_guess_from_filename($regular_file);
 151         if (defined($comp)) {
 152             $file = $regular_file;
 153             my $ext = compression_get_property($comp, 'file_ext');
 154             $file =~ s/\.$ext$/.src.$ext/;
 155         } else {
 156             $file = "$regular_file.src";
 157         }
 158         return unless -e $file;
 159     }
 160     else {
 161         return;
 162     }
 163
 164     debug(1, "source override file $file");
 165     my $comp_file = Dpkg::Compression::FileHandle->new(filename => $file);
 166     while (<$comp_file>) {
 167         s/#.*//;
 168         next if /^\s*$/;
 169         s/\s+$//;
 170
 171         my @data = split ' ';
 172         unless (@data == 2) {
 173             warning(g_('invalid source override entry at line %d (%d fields)'),
 174                     $., 0 + @data);
 175             next;
 176         }
 177
 178         my ($package, $section) = @data;
 179         my $key = "source/$package";
 180         if (exists $override{$key}) {
 181             warning(g_('ignoring duplicate source override entry for %s at line %d'),
 182                     $package, $.);
 183             next;
 184         }
 185         $override{$key} = [];
 186         $override{$key}[O_SECTION] = $section;
 187     }
 188     close($comp_file);
 189 }
 190
 191 sub load_override_extra
 192 {
 193     my $extra_override = shift;
 194     my $comp_file = Dpkg::Compression::FileHandle->new(filename => $extra_override);
 195
 196     while (<$comp_file>) {
 197         s/\#.*//;
 198         s/\s+$//;
 199         next unless $_;
 200
 201         my ($p, $field, $value) = split(/\s+/, $_, 3);
 202         $extra_override{$p}{$field} = $value;
 203     }
 204     close($comp_file);
 205 }
 206
 207 # Given PREFIX and DSC-FILE, process the file and returns the fields.
 208
 209 sub process_dsc {
 210     my ($prefix, $file) = @_;
 211
 212     my $basename = $file;
 213     my $dir = ($basename =~ s{^(.*)/}{}) ? $1 : '';
 214     $dir = "$prefix$dir";
 215     $dir =~ s{/+$}{};
 216     $dir = '.' if $dir eq '';
 217
 218     # Parse ‘.dsc’ file.
 219     my $fields = Dpkg::Control->new(type => CTRL_PKG_SRC);
 220     $fields->load($file);
 221     $fields->set_options(type => CTRL_INDEX_SRC);
 222
 223     # Get checksums
 224     my $checksums = Dpkg::Checksums->new();
 225     $checksums->add_from_file($file, key => $basename);
 226     $checksums->add_from_control($fields, use_files_for_md5 => 1);
 227
 228     my $source = $fields->{Source};
 229     my @binary = split /\s*,\s*/, $fields->{Binary} // '';
 230
 231     error(g_('no binary packages specified in %s'), $file) unless (@binary);
 232
 233     # Rename the source field to package.
 234     $fields->{Package} = $fields->{Source};
 235     delete $fields->{Source};
 236
 237     # The priority for the source package is the highest priority of the
 238     # binary packages it produces.
 239     my @binary_by_priority = sort {
 240             ($override{$a} ? $priority{$override{$a}[O_PRIORITY]} : 0)
 241                 <=>
 242             ($override{$b} ? $priority{$override{$b}[O_PRIORITY]} : 0)
 243         } @binary;
 244     my $priority_override = $override{$binary_by_priority[-1]};
 245     my $priority = $priority_override
 246                         ? $priority_override->[O_PRIORITY]
 247                         : undef;
 248     $fields->{Priority} = $priority if defined $priority;
 249
 250     # For the section override, first check for a record from the source
 251     # override file, else use the regular override file.
 252     my $section_override = $override{"source/$source"} || $override{$source};
 253     my $section = $section_override
 254                         ? $section_override->[O_SECTION]
 255                         : undef;
 256     $fields->{Section} = $section if defined $section;
 257
 258     # For the maintainer override, use the override record for the first
 259     # binary. Modify the maintainer if necessary.
 260     my $maintainer_override = $override{$binary[0]};
 261     if ($maintainer_override && defined $maintainer_override->[O_MAINT_TO]) {
 262         if (!defined $maintainer_override->[O_MAINT_FROM] ||
 263             any { $fields->{Maintainer} eq $_ }
 264                 @{ $maintainer_override->[O_MAINT_FROM] }) {
 265             $fields->{Maintainer} = $maintainer_override->[O_MAINT_TO];
 266         }
 267     }
 268
 269     # Process extra override
 270     if (exists $extra_override{$source}) {
 271         my ($field, $value);
 272         while (($field, $value) = each %{$extra_override{$source}}) {
 273             $fields->{$field} = $value;
 274         }
 275     }
 276
 277     # A directory field will be inserted just before the files field.
 278     $fields->{Directory} = $dir;
 279
 280     $checksums->export_to_control($fields, use_files_for_md5 => 1);
 281
 282     push @sources, $fields;
 283 }
 284
 285 ### Main
 286
 287 {
 288     local $SIG{__WARN__} = sub { usageerr($_[0]) };
 289     GetOptions(@option_spec);
 290 }
 291
 292 usageerr(g_('one to three arguments expected'))
 293     if @ARGV < 1 or @ARGV > 3;
 294
 295 push @ARGV, undef if @ARGV < 2;
 296 push @ARGV, '' if @ARGV < 3;
 297 my ($dir, $override, $prefix) = @ARGV;
 298
 299 report_options(debug_level => $debug);
 300
 301 load_override $override if defined $override;
 302 load_src_override $src_override, $override;
 303 load_override_extra $extra_override_file if defined $extra_override_file;
 304
 305 my @dsc;
 306 my $scan_dsc = sub {
 307     push @dsc, $File::Find::name if m/\.dsc$/;
 308 };
 309
 310 find({ follow => 1, follow_skip => 2, wanted => $scan_dsc }, $dir);
 311 foreach my $fn (@dsc) {
 312     # FIXME: Fix it instead to not die on syntax and general errors?
 313     eval {
 314         process_dsc($prefix, $fn);
 315     };
 316     if ($@) {
 317         warn $@;
 318         next;
 319     }
 320 }
 321
 322 if (not $no_sort) {
 323     @sources = sort {
 324         $a->{Package} . $a->{Version} cmp $b->{Package} . $b->{Version}
 325     } @sources;
 326 }
 327 foreach my $dsc (@sources) {
 328     $dsc->output(\*STDOUT);
 329     print "\n";
 330 }