diff options
Diffstat (limited to 'scripts/dd-list.pl')
| -rwxr-xr-x | scripts/dd-list.pl | 322 |
1 files changed, 322 insertions, 0 deletions
diff --git a/scripts/dd-list.pl b/scripts/dd-list.pl new file mode 100755 index 0000000..d1dbcfb --- /dev/null +++ b/scripts/dd-list.pl @@ -0,0 +1,322 @@ +#!/usr/bin/perl +# +# dd-list: Generate a list of maintainers of packages. +# +# Written by Joey Hess <joeyh@debian.org> +# Modifications by James McCoy <jamessan@debian.org> +# Based on a python implementation by Lars Wirzenius. +# Copyright 2005 Lars Wirzenius, Joey Hess +# +# 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 FileHandle; +use Getopt::Long qw(:config bundling permute no_getopt_compat); +use Dpkg::Version; +use Dpkg::IPC; + +my $uncompress; + +BEGIN { + $uncompress = eval { + require IO::Uncompress::AnyUncompress; + IO::Uncompress::AnyUncompress->import('$AnyUncompressError'); + 1; + }; +} + +my $version = '###VERSION###'; + +sub normalize_package { + my $name = shift; + # Remove any arch-qualifier + $name =~ s/:.*//; + return lc($name); +} + +sub sort_developers { + return map { $_->[0] } + sort { $a->[1] cmp $b->[1] } + map { [$_, uc] } @_; +} + +sub help { + print <<"EOF"; +Usage: dd-list [options] [package ...] + + -h, --help + Print this help text. + + -i, --stdin + Read package names from the standard input. + + -d, --dctrl + Read package list in Debian control data from standard input. + + -z, --uncompress + Try to uncompress the --dctrl input before parsing. Supported + compression formats are gz, bzip2 and xz. + + -s, --sources SOURCES_FILE + Read package information from given SOURCES_FILE instead of all files + matching /var/lib/apt/lists/*_source_Sources. Can be specified + multiple times. The files can be gz, bzip2 or xz compressed. + + -u, --uploaders + Also list Uploaders of packages, not only the listed Maintainers + (this is the default behaviour, use --nouploaders to prevent this). + + -nou, --nouploaders + Only list package Maintainers, do not list Uploaders. + + -b, --print-binary + If binary package names are given as input, print these names + in the output instead of corresponding source packages. + + -V, --version + Print version (it\'s $version by the way). +EOF +} + +my $use_stdin = 0; +my $use_dctrl = 0; +my $source_files = []; +my $show_uploaders = 1; +my $opt_uncompress = 0; +my $print_binary = 0; +GetOptions( + "help|h" => sub { help(); exit }, + "stdin|i" => \$use_stdin, + "dctrl|d" => \$use_dctrl, + "sources|s=s@" => \$source_files, + "uploaders|u!" => \$show_uploaders, + 'z|uncompress' => \$opt_uncompress, + "print-binary|b" => \$print_binary, + "version" => sub { print "dd-list version $version\n" }) + or do { + help(); + exit(1); + }; + +if ($opt_uncompress && !$uncompress) { + warn +"You must have the libio-compress-perl package installed to use the -z option.\n"; + exit 1; +} + +my %dict; +my $errors = 0; +my %package_name; + +sub parsefh { + my ($fh, $fname, $check_package) = @_; + local $/ = "\n\n"; + my $package_names; + if ($check_package) { + $package_names = sprintf '(?:^| )(%s)(?:,|$)', + join '|', map { "\Q$_\E" } + keys %package_name; + } + my %sources; + while (<$fh>) { + my ($package, $source, $binaries, $maintainer, @uploaders); + + # These source packages are only kept around because of stale binaries + # on old archs or due to Built-Using relationships. + if (/^Extra-Source-Only:\s+yes/m) { + next; + } + + # Binary is shown in _source_Sources and contains all binaries produced by + # that source package + if (/^Binary:\s+(.*(?:\n .*)*)$/m) { + $binaries = $1; + $binaries =~ s/\n//; + } + # Package is shown both in _source_Sources and _binary-*. It is the + # name of the package, source or binary respectively, being described + # in that control stanza + if (/^Package:\s+(.*)$/m) { + $package = $1; + } + # Source is shown in _binary-* and specifies the source package which + # produced the binary being described + if (/^Source:\s+(.*)$/m) { + $source = $1; + } + if (/^Maintainer:\s+(.*)$/m) { + $maintainer = $1; + } + if (/^Uploaders:\s+(.*(?:\n .*)*)$/m) { + my $matches = $1; + $matches =~ s/\n//g; + @uploaders = split /(?<=>)\s*,\s*/, $matches; + } + my $version = '0~0~0'; + if (/^Version:\s+(.*)$/m) { + $version = $1; + } + + if (defined $maintainer + && (defined $package || defined $source || defined $binaries)) { + $source ||= $package; + $binaries ||= $package; + my @names; + if ($check_package) { + my @pkgs; + if (@pkgs = ($binaries =~ m/$package_names/g)) { + $sources{$source}{$version}{binaries} = [@pkgs]; + } elsif ($source !~ m/$package_names/) { + next; + } + } else { + $sources{$source}{$version}{binaries} = [$binaries]; + } + $sources{$source}{$version}{maintainer} = $maintainer; + $sources{$source}{$version}{uploaders} = [@uploaders]; + } else { + warn "E: parse error in stanza $. of $fname\n"; + $errors = 1; + } + } + + for my $source (keys %sources) { + my @versions + = sort map { Dpkg::Version->new($_) } keys %{ $sources{$source} }; + my $version = $versions[-1]; + my $srcinfo = $sources{$source}{$version}; + my @names; + if ($check_package) { + $package_name{$source}--; + $package_name{$_}-- for @{ $srcinfo->{binaries} }; + } + @names = $print_binary ? @{ $srcinfo->{binaries} } : $source; + push @{ $dict{ $srcinfo->{maintainer} } }, @names; + if ($show_uploaders && @{ $srcinfo->{uploaders} }) { + foreach my $uploader (@{ $srcinfo->{uploaders} }) { + push @{ $dict{$uploader} }, map "$_ (U)", @names; + } + } + } +} + +if ($use_dctrl) { + my $fh; + if ($uncompress) { + $fh = IO::Uncompress::AnyUncompress->new('-') + or die "E: Unable to decompress STDIN: $AnyUncompressError\n"; + } else { + $fh = \*STDIN; + } + parsefh($fh, 'STDIN'); +} else { + my @packages; + if ($use_stdin) { + while (my $line = <STDIN>) { + chomp $line; + $line =~ s/^\s+|\s+$//g; + push @packages, split(' ', $line); + } + } else { + @packages = @ARGV; + } + for my $name (@packages) { + $package_name{ normalize_package($name) } = 1; + } + + my $apt_version; + spawn( + exec => ['dpkg-query', '-W', '-f', '${source:Version}', 'apt'], + to_string => \$apt_version, + wait_child => 1, + nocheck => 1 + ); + + my $useAptHelper = 0; + if (defined $apt_version) { + $useAptHelper + = version_compare_relation($apt_version, REL_GE, '1.1.8'); + } + + unless (@{$source_files}) { + if ($useAptHelper) { + my ($sources, $err); + spawn( + exec => [ + 'apt-get', 'indextargets', + '--format', '$(FILENAME)', + 'Created-By: Sources' + ], + to_string => \$sources, + error_to_string => \$err, + wait_child => 1, + nocheck => 1 + ); + if ($? >> 8) { + die "Unable to get list of Sources files from apt: $err\n"; + } + + $source_files = [split(/\n/, $sources)]; + } else { + $source_files = [glob('/var/lib/apt/lists/*_source_Sources')]; + } + } + + foreach my $source (@{$source_files}) { + my $fh; + if ($useAptHelper) { + my $good = open($fh, '-|', '/usr/lib/apt/apt-helper', 'cat-file', + $source); + if (!$good) { + warn +"E: Couldn't run apt-helper to get contents of '$source': $!\n"; + $errors = 1; + next; + } + } else { + if ($opt_uncompress + || ($uncompress && $source =~ m/\.(?:gz|bz2|xz)$/)) { + $fh = IO::Uncompress::AnyUncompress->new($source); + } else { + $fh = FileHandle->new("<$source"); + } + unless (defined $fh) { + warn "E: Couldn't open $source\n"; + $errors = 1; + next; + } + } + parsefh($fh, $source, 1); + close $fh; + } +} + +foreach my $developer (sort_developers(keys %dict)) { + print "$developer\n"; + my %seen; + foreach my $package (sort @{ $dict{$developer} }) { + next if $seen{$package}; + $seen{$package} = 1; + print " $package\n"; + } + print "\n"; +} + +foreach my $package (grep { $package_name{$_} > 0 } keys %package_name) { + warn "E: Unknown package: $package\n"; + $errors = 1; +} + +exit($errors); |