1#!/usr/bin/perl
2#
3# dd-list: Generate a list of maintainers of packages.
4#
5# Written by Joey Hess <joeyh@debian.org>
6# Modifications by James McCoy <jamessan@debian.org>
7# Based on a python implementation by Lars Wirzenius.
8# Copyright 2005 Lars Wirzenius, Joey Hess
9#
10# This program is free software; you can redistribute it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program. If not, see <https://www.gnu.org/licenses/>.
22
23use strict;
24use warnings;
25use FileHandle;
26use Getopt::Long qw(:config bundling permute no_getopt_compat);
27use Dpkg::Version;
28use Dpkg::IPC;
29
30my $uncompress;
31
32BEGIN {
33    $uncompress = eval {
34        require IO::Uncompress::AnyUncompress;
35        IO::Uncompress::AnyUncompress->import('$AnyUncompressError');
36        1;
37    };
38}
39
40my $version = '###VERSION###';
41
42sub normalize_package {
43    my $name = shift;
44    # Remove any arch-qualifier
45    $name =~ s/:.*//;
46    return lc($name);
47}
48
49sub sort_developers {
50    return map { $_->[0] }
51      sort     { $a->[1] cmp $b->[1] }
52      map      { [$_, uc] } @_;
53}
54
55sub help {
56    print <<"EOF";
57Usage: dd-list [options] [package ...]
58
59    -h, --help
60        Print this help text.
61
62    -i, --stdin
63        Read package names from the standard input.
64
65    -d, --dctrl
66        Read package list in Debian control data from standard input.
67
68    -z, --uncompress
69        Try to uncompress the --dctrl input before parsing.  Supported
70        compression formats are gz, bzip2 and xz.
71
72    -s, --sources SOURCES_FILE
73        Read package information from given SOURCES_FILE instead of all files
74        matching /var/lib/apt/lists/*_source_Sources.  Can be specified
75        multiple times.  The files can be gz, bzip2 or xz compressed.
76
77    -u, --uploaders
78        Also list Uploaders of packages, not only the listed Maintainers
79        (this is the default behaviour, use --nouploaders to prevent this).
80
81    -nou, --nouploaders
82        Only list package Maintainers, do not list Uploaders.
83
84    -b, --print-binary
85        If binary package names are given as input, print these names
86        in the output instead of corresponding source packages.
87
88    -V, --version
89        Print version (it\'s $version by the way).
90EOF
91}
92
93my $use_stdin      = 0;
94my $use_dctrl      = 0;
95my $source_files   = [];
96my $show_uploaders = 1;
97my $opt_uncompress = 0;
98my $print_binary   = 0;
99GetOptions(
100    "help|h"         => sub { help(); exit },
101    "stdin|i"        => \$use_stdin,
102    "dctrl|d"        => \$use_dctrl,
103    "sources|s=s@"   => \$source_files,
104    "uploaders|u!"   => \$show_uploaders,
105    'z|uncompress'   => \$opt_uncompress,
106    "print-binary|b" => \$print_binary,
107    "version"        => sub { print "dd-list version $version\n" })
108  or do {
109    help();
110    exit(1);
111  };
112
113if ($opt_uncompress && !$uncompress) {
114    warn
115"You must have the libio-compress-perl package installed to use the -z option.\n";
116    exit 1;
117}
118
119my %dict;
120my $errors = 0;
121my %package_name;
122
123sub parsefh {
124    my ($fh, $fname, $check_package) = @_;
125    local $/ = "\n\n";
126    my $package_names;
127    if ($check_package) {
128        $package_names = sprintf '(?:^| )(%s)(?:,|$)',
129          join '|', map { "\Q$_\E" }
130          keys %package_name;
131    }
132    my %sources;
133    while (<$fh>) {
134        my ($package, $source, $binaries, $maintainer, @uploaders);
135
136        # These source packages are only kept around because of stale binaries
137        # on old archs or due to Built-Using relationships.
138        if (/^Extra-Source-Only:\s+yes/m) {
139            next;
140        }
141
142     # Binary is shown in _source_Sources and contains all binaries produced by
143     # that source package
144        if (/^Binary:\s+(.*(?:\n .*)*)$/m) {
145            $binaries = $1;
146            $binaries =~ s/\n//;
147        }
148        # Package is shown both in _source_Sources and _binary-*.  It is the
149        # name of the package, source or binary respectively, being described
150        # in that control stanza
151        if (/^Package:\s+(.*)$/m) {
152            $package = $1;
153        }
154        # Source is shown in _binary-* and specifies the source package which
155        # produced the binary being described
156        if (/^Source:\s+(.*)$/m) {
157            $source = $1;
158        }
159        if (/^Maintainer:\s+(.*)$/m) {
160            $maintainer = $1;
161        }
162        if (/^Uploaders:\s+(.*(?:\n .*)*)$/m) {
163            my $matches = $1;
164            $matches =~ s/\n//g;
165            @uploaders = split /(?<=>)\s*,\s*/, $matches;
166        }
167        my $version = '0~0~0';
168        if (/^Version:\s+(.*)$/m) {
169            $version = $1;
170        }
171
172        if (defined $maintainer
173            && (defined $package || defined $source || defined $binaries)) {
174            $source   ||= $package;
175            $binaries ||= $package;
176            my @names;
177            if ($check_package) {
178                my @pkgs;
179                if (@pkgs = ($binaries =~ m/$package_names/g)) {
180                    $sources{$source}{$version}{binaries} = [@pkgs];
181                } elsif ($source !~ m/$package_names/) {
182                    next;
183                }
184            } else {
185                $sources{$source}{$version}{binaries} = [$binaries];
186            }
187            $sources{$source}{$version}{maintainer} = $maintainer;
188            $sources{$source}{$version}{uploaders}  = [@uploaders];
189        } else {
190            warn "E: parse error in stanza $. of $fname\n";
191            $errors = 1;
192        }
193    }
194
195    for my $source (keys %sources) {
196        my @versions
197          = sort map { Dpkg::Version->new($_) } keys %{ $sources{$source} };
198        my $version = $versions[-1];
199        my $srcinfo = $sources{$source}{$version};
200        my @names;
201        if ($check_package) {
202            $package_name{$source}--;
203            $package_name{$_}-- for @{ $srcinfo->{binaries} };
204        }
205        @names = $print_binary ? @{ $srcinfo->{binaries} } : $source;
206        push @{ $dict{ $srcinfo->{maintainer} } }, @names;
207        if ($show_uploaders && @{ $srcinfo->{uploaders} }) {
208            foreach my $uploader (@{ $srcinfo->{uploaders} }) {
209                push @{ $dict{$uploader} }, map "$_ (U)", @names;
210            }
211        }
212    }
213}
214
215if ($use_dctrl) {
216    my $fh;
217    if ($uncompress) {
218        $fh = IO::Uncompress::AnyUncompress->new('-')
219          or die "E: Unable to decompress STDIN: $AnyUncompressError\n";
220    } else {
221        $fh = \*STDIN;
222    }
223    parsefh($fh, 'STDIN');
224} else {
225    my @packages;
226    if ($use_stdin) {
227        while (my $line = <STDIN>) {
228            chomp $line;
229            $line =~ s/^\s+|\s+$//g;
230            push @packages, split(' ', $line);
231        }
232    } else {
233        @packages = @ARGV;
234    }
235    for my $name (@packages) {
236        $package_name{ normalize_package($name) } = 1;
237    }
238
239    my $apt_version;
240    spawn(
241        exec       => ['dpkg-query', '-W', '-f', '${source:Version}', 'apt'],
242        to_string  => \$apt_version,
243        wait_child => 1,
244        nocheck    => 1
245    );
246
247    my $useAptHelper = 0;
248    if (defined $apt_version) {
249        $useAptHelper
250          = version_compare_relation($apt_version, REL_GE, '1.1.8');
251    }
252
253    unless (@{$source_files}) {
254        if ($useAptHelper) {
255            my ($sources, $err);
256            spawn(
257                exec => [
258                    'apt-get',  'indextargets',
259                    '--format', '$(FILENAME)',
260                    'Created-By: Sources'
261                ],
262                to_string       => \$sources,
263                error_to_string => \$err,
264                wait_child      => 1,
265                nocheck         => 1
266            );
267            if ($? >> 8) {
268                die "Unable to get list of Sources files from apt: $err\n";
269            }
270
271            $source_files = [split(/\n/, $sources)];
272        } else {
273            $source_files = [glob('/var/lib/apt/lists/*_source_Sources')];
274        }
275    }
276
277    foreach my $source (@{$source_files}) {
278        my $fh;
279        if ($useAptHelper) {
280            my $good = open($fh, '-|', '/usr/lib/apt/apt-helper', 'cat-file',
281                $source);
282            if (!$good) {
283                warn
284"E: Couldn't run apt-helper to get contents of '$source': $!\n";
285                $errors = 1;
286                next;
287            }
288        } else {
289            if ($opt_uncompress
290                || ($uncompress && $source =~ m/\.(?:gz|bz2|xz)$/)) {
291                $fh = IO::Uncompress::AnyUncompress->new($source);
292            } else {
293                $fh = FileHandle->new("<$source");
294            }
295            unless (defined $fh) {
296                warn "E: Couldn't open $source\n";
297                $errors = 1;
298                next;
299            }
300        }
301        parsefh($fh, $source, 1);
302        close $fh;
303    }
304}
305
306foreach my $developer (sort_developers(keys %dict)) {
307    print "$developer\n";
308    my %seen;
309    foreach my $package (sort @{ $dict{$developer} }) {
310        next if $seen{$package};
311        $seen{$package} = 1;
312        print "   $package\n";
313    }
314    print "\n";
315}
316
317foreach my $package (grep { $package_name{$_} > 0 } keys %package_name) {
318    warn "E: Unknown package: $package\n";
319    $errors = 1;
320}
321
322exit($errors);
323