devscripts 2.17.6+deb9u2 / usr / bin / dd-list

#!/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='2.17.6+deb9u2';

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);