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_values no_ignorecase);
  24 use List::Util qw(any);
  25 use File::Find;
  26
  27 use Dpkg ();
  28 use Dpkg::Gettext;
  29 use Dpkg::ErrorHandling;
  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         } elsif ($maintainer =~ /^(.*\S)\s*=>\s*(.*)$/) {
 130             $override{$package}[O_MAINT_TO] = $2;
 131             $override{$package}[O_MAINT_FROM] = [split m{\s*//\s*}, $1];
 132         } else {
 133             $override{$package}[O_MAINT_TO] = $maintainer;
 134         }
 135     }
 136     close($comp_file);
 137 }
 138
 139 sub load_src_override {
 140     my ($user_file, $regular_file) = @_;
 141     my ($file);
 142     local $_;
 143
 144     if (defined $user_file) {
 145         $file = $user_file;
 146     } elsif (defined $regular_file) {
 147         my $comp = compression_guess_from_filename($regular_file);
 148         if (defined($comp)) {
 149             $file = $regular_file;
 150             my $ext = compression_get_file_extension($comp);
 151             $file =~ s/\.$ext$/.src.$ext/;
 152         } else {
 153             $file = "$regular_file.src";
 154         }
 155         return unless -e $file;
 156     } else {
 157         return;
 158     }
 159
 160     debug(1, "source override file $file");
 161     my $comp_file = Dpkg::Compression::FileHandle->new(filename => $file);
 162     while (<$comp_file>) {
 163         s/#.*//;
 164         next if /^\s*$/;
 165         s/\s+$//;
 166
 167         my @data = split ' ';
 168         unless (@data == 2) {
 169             warning(g_('invalid source override entry at line %d (%d fields)'),
 170                     $., 0 + @data);
 171             next;
 172         }
 173
 174         my ($package, $section) = @data;
 175         my $key = "source/$package";
 176         if (exists $override{$key}) {
 177             warning(g_('ignoring duplicate source override entry for %s at line %d'),
 178                     $package, $.);
 179             next;
 180         }
 181         $override{$key} = [];
 182         $override{$key}[O_SECTION] = $section;
 183     }
 184     close($comp_file);
 185 }
 186
 187 sub load_override_extra
 188 {
 189     my $extra_override = shift;
 190     my $comp_file = Dpkg::Compression::FileHandle->new(filename => $extra_override);
 191
 192     while (<$comp_file>) {
 193         s/\#.*//;
 194         s/\s+$//;
 195         next unless $_;
 196
 197         my ($p, $field, $value) = split(/\s+/, $_, 3);
 198         $extra_override{$p}{$field} = $value;
 199     }
 200     close($comp_file);
 201 }
 202
 203 # Given PREFIX and DSC-FILE, process the file and returns the fields.
 204
 205 sub process_dsc {
 206     my ($prefix, $file) = @_;
 207
 208     my $basename = $file;
 209     ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
 210     my $dir = ($basename =~ s{^(.*)/}{}) ? $1 : '';
 211     $dir = "$prefix$dir";
 212     $dir =~ s{/+$}{};
 213     $dir = '.' if $dir eq '';
 214
 215     # Parse ‘.dsc’ file.
 216     my $fields = Dpkg::Control->new(type => CTRL_PKG_SRC);
 217     $fields->load($file);
 218     $fields->set_options(type => CTRL_INDEX_SRC);
 219
 220     # Get checksums
 221     my $checksums = Dpkg::Checksums->new();
 222     $checksums->add_from_file($file, key => $basename);
 223     $checksums->add_from_control($fields, use_files_for_md5 => 1);
 224
 225     my $source = $fields->{Source};
 226     my @binary = split /\s*,\s*/, $fields->{Binary} // '';
 227
 228     error(g_('no binary packages specified in %s'), $file) unless (@binary);
 229
 230     # Rename the source field to package.
 231     $fields->{Package} = $fields->{Source};
 232     delete $fields->{Source};
 233
 234     # The priority for the source package is the highest priority of the
 235     # binary packages it produces.
 236     my @binary_by_priority = sort {
 237         ($override{$a} ? $priority{$override{$a}[O_PRIORITY]} : 0)
 238         <=>
 239         ($override{$b} ? $priority{$override{$b}[O_PRIORITY]} : 0)
 240     } @binary;
 241     my $priority_override = $override{$binary_by_priority[-1]};
 242     my $priority = $priority_override
 243                         ? $priority_override->[O_PRIORITY]
 244                         : undef;
 245     $fields->{Priority} = $priority if defined $priority;
 246
 247     # For the section override, first check for a record from the source
 248     # override file, else use the regular override file.
 249     my $section_override = $override{"source/$source"} || $override{$source};
 250     my $section = $section_override
 251                         ? $section_override->[O_SECTION]
 252                         : undef;
 253     $fields->{Section} = $section if defined $section;
 254
 255     # For the maintainer override, use the override record for the first
 256     # binary. Modify the maintainer if necessary.
 257     my $maintainer_override = $override{$binary[0]};
 258     if ($maintainer_override && defined $maintainer_override->[O_MAINT_TO]) {
 259         if (!defined $maintainer_override->[O_MAINT_FROM] ||
 260             any { $fields->{Maintainer} eq $_ }
 261                 @{ $maintainer_override->[O_MAINT_FROM] }) {
 262             $fields->{Maintainer} = $maintainer_override->[O_MAINT_TO];
 263         }
 264     }
 265
 266     # Process extra override
 267     if (exists $extra_override{$source}) {
 268         my ($field, $value);
 269         while (($field, $value) = each %{$extra_override{$source}}) {
 270             $fields->{$field} = $value;
 271         }
 272     }
 273
 274     # A directory field will be inserted just before the files field.
 275     $fields->{Directory} = $dir;
 276
 277     $checksums->export_to_control($fields, use_files_for_md5 => 1);
 278
 279     push @sources, $fields;
 280 }
 281
 282 ### Main
 283
 284 {
 285     local $SIG{__WARN__} = sub { usageerr($_[0]) };
 286     GetOptions(@option_spec);
 287 }
 288
 289 usageerr(g_('one to three arguments expected'))
 290     if not 1 <= @ARGV <= 3;
 291
 292 push @ARGV, undef if @ARGV < 2;
 293 push @ARGV, '' if @ARGV < 3;
 294 my ($dir, $override, $prefix) = @ARGV;
 295
 296 report_options(debug_level => $debug);
 297
 298 load_override $override if defined $override;
 299 load_src_override $src_override, $override;
 300 load_override_extra $extra_override_file if defined $extra_override_file;
 301
 302 my @dsc;
 303 my $scan_dsc = sub {
 304     push @dsc, $File::Find::name if m/\.dsc$/;
 305 };
 306
 307 find({ follow => 1, follow_skip => 2, wanted => $scan_dsc }, $dir);
 308 foreach my $fn (@dsc) {
 309     # FIXME: Fix it instead to not die on syntax and general errors?
 310     eval {
 311         process_dsc($prefix, $fn);
 312     };
 313     if ($@) {
 314         warn $@;
 315         next;
 316     }
 317 }
 318
 319 if (not $no_sort) {
 320     @sources = sort {
 321         $a->{Package} . $a->{Version} cmp $b->{Package} . $b->{Version}
 322     } @sources;
 323 }
 324 foreach my $dsc (@sources) {
 325     $dsc->output(\*STDOUT);
 326     print "\n";
 327 }