summaryrefslogtreecommitdiffstats
path: root/scripts/dpkg-scansources.pl
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 14:58:51 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 14:58:51 +0000
commitcbffab246997fb5a06211dfb706b54e5ae5bb59f (patch)
tree0573c5d96f58d74d76a49c0f2a70398e389a36d3 /scripts/dpkg-scansources.pl
parentInitial commit. (diff)
downloaddpkg-cbffab246997fb5a06211dfb706b54e5ae5bb59f.tar.xz
dpkg-cbffab246997fb5a06211dfb706b54e5ae5bb59f.zip
Adding upstream version 1.21.22.upstream/1.21.22upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'scripts/dpkg-scansources.pl')
-rwxr-xr-xscripts/dpkg-scansources.pl326
1 files changed, 326 insertions, 0 deletions
diff --git a/scripts/dpkg-scansources.pl b/scripts/dpkg-scansources.pl
new file mode 100755
index 0000000..da19ba7
--- /dev/null
+++ b/scripts/dpkg-scansources.pl
@@ -0,0 +1,326 @@
+#!/usr/bin/perl
+#
+# Copyright © 1999 Roderick Schertler
+# Copyright © 2002 Wichert Akkerman <wakkerma@debian.org>
+# Copyright © 2006-2009, 2011-2015 Guillem Jover <guillem@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or (at
+# your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+use strict;
+use warnings;
+
+use Getopt::Long qw(:config posix_default bundling_values no_ignorecase);
+use List::Util qw(any);
+use File::Find;
+
+use Dpkg ();
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Control;
+use Dpkg::Checksums;
+use Dpkg::Compression::FileHandle;
+use Dpkg::Compression;
+
+textdomain('dpkg-dev');
+
+# Hash of lists. The constants below describe what is in the lists.
+my %override;
+use constant {
+ O_PRIORITY => 0,
+ O_SECTION => 1,
+ O_MAINT_FROM => 2, # undef for non-specific, else listref
+ O_MAINT_TO => 3, # undef if there's no maint override
+};
+
+my %extra_override;
+
+my %priority = (
+ 'extra' => 1,
+ 'optional' => 2,
+ 'standard' => 3,
+ 'important' => 4,
+ 'required' => 5,
+);
+
+# Switches
+
+my $debug = 0;
+my $no_sort = 0;
+my $src_override = undef;
+my $extra_override_file = undef;
+my @sources;
+
+my @option_spec = (
+ 'debug!' => \$debug,
+ 'help|?' => sub { usage(); exit 0; },
+ 'version' => sub { version(); exit 0; },
+ 'no-sort|n' => \$no_sort,
+ 'source-override|s=s' => \$src_override,
+ 'extra-override|e=s' => \$extra_override_file,
+);
+
+sub version {
+ printf g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION;
+}
+
+sub usage {
+ printf g_(
+"Usage: %s [<option>...] <binary-path> [<override-file> [<path-prefix>]] > Sources
+
+Options:
+ -n, --no-sort don't sort by package before outputting.
+ -e, --extra-override <file>
+ use extra override file.
+ -s, --source-override <file>
+ use file for additional source overrides, default
+ is regular override file with .src appended.
+ --debug turn debugging on.
+ -?, --help show this help message.
+ --version show the version.
+
+See the man page for the full documentation.
+"), $Dpkg::PROGNAME;
+}
+
+sub load_override {
+ my $file = shift;
+ local $_;
+
+ my $comp_file = Dpkg::Compression::FileHandle->new(filename => $file);
+ while (<$comp_file>) {
+ s/#.*//;
+ next if /^\s*$/;
+ s/\s+$//;
+
+ my @data = split ' ', $_, 4;
+ unless (@data == 3 || @data == 4) {
+ warning(g_('invalid override entry at line %d (%d fields)'),
+ $., 0 + @data);
+ next;
+ }
+ my ($package, $priority, $section, $maintainer) = @data;
+ if (exists $override{$package}) {
+ warning(g_('ignoring duplicate override entry for %s at line %d'),
+ $package, $.);
+ next;
+ }
+ if (!$priority{$priority}) {
+ warning(g_('ignoring override entry for %s, invalid priority %s'),
+ $package, $priority);
+ next;
+ }
+
+ $override{$package} = [];
+ $override{$package}[O_PRIORITY] = $priority;
+ $override{$package}[O_SECTION] = $section;
+ if (!defined $maintainer) {
+ # do nothing
+ } elsif ($maintainer =~ /^(.*\S)\s*=>\s*(.*)$/) {
+ $override{$package}[O_MAINT_FROM] = [split m{\s*//\s*}, $1];
+ $override{$package}[O_MAINT_TO] = $2;
+ } else {
+ $override{$package}[O_MAINT_TO] = $maintainer;
+ }
+ }
+ close($comp_file);
+}
+
+sub load_src_override {
+ my ($user_file, $regular_file) = @_;
+ my ($file);
+ local $_;
+
+ if (defined $user_file) {
+ $file = $user_file;
+ } elsif (defined $regular_file) {
+ my $comp = compression_guess_from_filename($regular_file);
+ if (defined($comp)) {
+ $file = $regular_file;
+ my $ext = compression_get_file_extension($comp);
+ $file =~ s/\.$ext$/.src.$ext/;
+ } else {
+ $file = "$regular_file.src";
+ }
+ return unless -e $file;
+ } else {
+ return;
+ }
+
+ debug(1, "source override file $file");
+ my $comp_file = Dpkg::Compression::FileHandle->new(filename => $file);
+ while (<$comp_file>) {
+ s/#.*//;
+ next if /^\s*$/;
+ s/\s+$//;
+
+ my @data = split ' ';
+ unless (@data == 2) {
+ warning(g_('invalid source override entry at line %d (%d fields)'),
+ $., 0 + @data);
+ next;
+ }
+
+ my ($package, $section) = @data;
+ my $key = "source/$package";
+ if (exists $override{$key}) {
+ warning(g_('ignoring duplicate source override entry for %s at line %d'),
+ $package, $.);
+ next;
+ }
+ $override{$key} = [];
+ $override{$key}[O_SECTION] = $section;
+ }
+ close($comp_file);
+}
+
+sub load_override_extra
+{
+ my $extra_override = shift;
+ my $comp_file = Dpkg::Compression::FileHandle->new(filename => $extra_override);
+
+ while (<$comp_file>) {
+ s/\#.*//;
+ s/\s+$//;
+ next unless $_;
+
+ my ($p, $field, $value) = split(/\s+/, $_, 3);
+ $extra_override{$p}{$field} = $value;
+ }
+ close($comp_file);
+}
+
+# Given PREFIX and DSC-FILE, process the file and returns the fields.
+
+sub process_dsc {
+ my ($prefix, $file) = @_;
+
+ my $basename = $file;
+ my $dir = ($basename =~ s{^(.*)/}{}) ? $1 : '';
+ $dir = "$prefix$dir";
+ $dir =~ s{/+$}{};
+ $dir = '.' if $dir eq '';
+
+ # Parse ‘.dsc’ file.
+ my $fields = Dpkg::Control->new(type => CTRL_PKG_SRC);
+ $fields->load($file);
+ $fields->set_options(type => CTRL_INDEX_SRC);
+
+ # Get checksums
+ my $checksums = Dpkg::Checksums->new();
+ $checksums->add_from_file($file, key => $basename);
+ $checksums->add_from_control($fields, use_files_for_md5 => 1);
+
+ my $source = $fields->{Source};
+ my @binary = split /\s*,\s*/, $fields->{Binary} // '';
+
+ error(g_('no binary packages specified in %s'), $file) unless (@binary);
+
+ # Rename the source field to package.
+ $fields->{Package} = $fields->{Source};
+ delete $fields->{Source};
+
+ # The priority for the source package is the highest priority of the
+ # binary packages it produces.
+ my @binary_by_priority = sort {
+ ($override{$a} ? $priority{$override{$a}[O_PRIORITY]} : 0)
+ <=>
+ ($override{$b} ? $priority{$override{$b}[O_PRIORITY]} : 0)
+ } @binary;
+ my $priority_override = $override{$binary_by_priority[-1]};
+ my $priority = $priority_override
+ ? $priority_override->[O_PRIORITY]
+ : undef;
+ $fields->{Priority} = $priority if defined $priority;
+
+ # For the section override, first check for a record from the source
+ # override file, else use the regular override file.
+ my $section_override = $override{"source/$source"} || $override{$source};
+ my $section = $section_override
+ ? $section_override->[O_SECTION]
+ : undef;
+ $fields->{Section} = $section if defined $section;
+
+ # For the maintainer override, use the override record for the first
+ # binary. Modify the maintainer if necessary.
+ my $maintainer_override = $override{$binary[0]};
+ if ($maintainer_override && defined $maintainer_override->[O_MAINT_TO]) {
+ if (!defined $maintainer_override->[O_MAINT_FROM] ||
+ any { $fields->{Maintainer} eq $_ }
+ @{ $maintainer_override->[O_MAINT_FROM] }) {
+ $fields->{Maintainer} = $maintainer_override->[O_MAINT_TO];
+ }
+ }
+
+ # Process extra override
+ if (exists $extra_override{$source}) {
+ my ($field, $value);
+ while (($field, $value) = each %{$extra_override{$source}}) {
+ $fields->{$field} = $value;
+ }
+ }
+
+ # A directory field will be inserted just before the files field.
+ $fields->{Directory} = $dir;
+
+ $checksums->export_to_control($fields, use_files_for_md5 => 1);
+
+ push @sources, $fields;
+}
+
+### Main
+
+{
+ local $SIG{__WARN__} = sub { usageerr($_[0]) };
+ GetOptions(@option_spec);
+}
+
+usageerr(g_('one to three arguments expected'))
+ if @ARGV < 1 or @ARGV > 3;
+
+push @ARGV, undef if @ARGV < 2;
+push @ARGV, '' if @ARGV < 3;
+my ($dir, $override, $prefix) = @ARGV;
+
+report_options(debug_level => $debug);
+
+load_override $override if defined $override;
+load_src_override $src_override, $override;
+load_override_extra $extra_override_file if defined $extra_override_file;
+
+my @dsc;
+my $scan_dsc = sub {
+ push @dsc, $File::Find::name if m/\.dsc$/;
+};
+
+find({ follow => 1, follow_skip => 2, wanted => $scan_dsc }, $dir);
+foreach my $fn (@dsc) {
+ # FIXME: Fix it instead to not die on syntax and general errors?
+ eval {
+ process_dsc($prefix, $fn);
+ };
+ if ($@) {
+ warn $@;
+ next;
+ }
+}
+
+if (not $no_sort) {
+ @sources = sort {
+ $a->{Package} . $a->{Version} cmp $b->{Package} . $b->{Version}
+ } @sources;
+}
+foreach my $dsc (@sources) {
+ $dsc->output(\*STDOUT);
+ print "\n";
+}