path: root/lib/Devscripts/Packages.pm

#! /usr/bin/perl

# Copyright Bill Allombert <ballombe@debian.org> 2001.
# Modifications copyright 2002 Julian Gilbey <jdg@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/>.

package Devscripts::Packages;

use strict;
use warnings;
use Carp;
use Dpkg::Control;
use Dpkg::IPC;
use FileHandle;

BEGIN {
    use Exporter ();
    use vars     qw(@EXPORT @ISA %EXPORT_TAGS);
    @EXPORT
      = qw(PackagesToFiles FilesToPackages PackagesMatch InstalledPackages);
    @ISA         = qw(Exporter);
    %EXPORT_TAGS = ();
}

=head1 NAME

Devscript::Packages - Interface to the dpkg package database

=head1 SYNOPSIS

use Devscript::Packages;

@files=PackagesToFiles(@packages);

@packages=FilesToPackages(@files);

@packages=PackagesMatch($regexp);

$packages_hashref=InstalledPackages($sources);

=head1 DESCRIPTION


PackagesToFiles: Return a list of files contained in a list of packages.

FilesToPackages: Return a list of packages containing at least
one file in a list of files, taking care to handle diversions correctly.

PackagesMatch: list of packages whose status match regexp.

InstalledPackages: ref to hash with keys being installed packages
(status = install ok installed).  If $sources is true, then include
the corresponding source packages as well in the list.

=cut

my $multiarch;

sub multiarch () {
    if (!defined $multiarch) {
        $multiarch
          = (system('dpkg --assert-multi-arch >/dev/null 2>&1') >> 8) == 0;
    }
    return $multiarch;
}

# input: a list of packages names.
# output: list of files they contain.

sub PackagesToFiles (@) {
    return () if @_ == 0;

    my %files = ();

    # We fork and use an exec, so that we don't have to worry how long an
    # input string the shell can handle.

    my $pid;
    my $sleep_count = 0;
    do {
        $pid = open(DPKG, "-|");
        unless (defined $pid) {
            carp("cannot fork: $!");
            croak("bailing out") if $sleep_count++ > 6;
            sleep 10;
        }
    } until defined $pid;

    if ($pid) {    # parent
        while (<DPKG>) {
            chomp;
            next if /^package diverts others to: / or -d $_;
            $files{$_} = 1;
        }
        close DPKG or croak("dpkg -L failed: $!");
    } else {       # child
            # We must use C locale, else diversion messages may be translated.
        $ENV{'LC_ALL'} = 'C';
        exec('dpkg', '-L', @_)
          or croak("can't exec dpkg -L: $!");
    }

    return keys %files;
}

# This basically runs a dpkg -S with a few bells and whistles
#
# input:  a list of files.
# output: list of packages they belong to.

sub FilesToPackages (@) {
    return () if @_ == 0;

    # We fork and use an exec, so that we don't have to worry how long an
    # input string the shell can handle.

    my @dpkg_out;
    my $pid;
    my $sleep_count = 0;
    do {
        $pid = open(DPKG, "-|");
        unless (defined $pid) {
            carp("cannot fork: $!");
            croak("bailing out") if $sleep_count++ > 6;
            sleep 10;
        }
    } until defined $pid;

    if ($pid) {    # parent
        while (<DPKG>) {
            # We'll process it later
            chomp;
            push @dpkg_out, $_;
        }
        if (!close DPKG) {
            # exit status of 1 just indicates unrecognised files
            if ($? & 0xff || $? >> 8 != 1) {
                carp(   "warning: dpkg -S exited with signal "
                      . ($? & 0xff)
                      . " and status "
                      . ($? >> 8));
            }
        }
    } else {    # child
            # We must use C locale, else diversion messages may be translated.
        $ENV{'LC_ALL'} = 'C';
        open STDERR, '>& STDOUT';    # Capture STDERR as well
        exec('dpkg', '-S', @_)
          or croak("can't exec dpkg -S: $!");
    }

    my %packages = ();
    foreach my $curfile (@_) {
        my $pkgfrom;
        foreach my $line (@dpkg_out) {
            # We want to handle diversions nicely.
            # Ignore local diversions
            if ($line =~ /^local diversion from: /) {
                # Do nothing
            } elsif ($line =~ /^local diversion to: (.+)$/) {
                if ($curfile eq $1) {
                    last;
                }
            } elsif ($line =~ /^diversion by (\S+) from: (.+)$/) {
                if ($curfile eq $2) {
                    # So the file we're looking has been diverted
                    $pkgfrom = $1;
                }
            } elsif ($line =~ /^diversion by (\S+) to: (.+)$/) {
                if ($curfile eq $2) {
                    # So the file we're looking is a diverted file
                    # We shouldn't see it again
                    $packages{$1} = 1;
                    last;
                }
            } elsif ($line =~ /^dpkg: \Q$curfile\E not found\.$/) {
                last;
            } elsif ($line
                =~ /^dpkg-query: no path found matching pattern \Q$curfile\E\.$/
            ) {
                last;
            } elsif ($line =~ /^(.*): \Q$curfile\E$/) {
                my @pkgs = split /,\s+/, $1;
                if (@pkgs == 1 || !grep /:/, @pkgs) {
                    # Only one package, or all Multi-Arch packages
                    map { $packages{$_} = 1 } @pkgs;
                } else {
                    # We've got a file which has been diverted by some package
                    # or is Multi-Arch and so is listed in two packages.  If it
                    # was diverted, the *diverting* package is the one with the
                    # file that was actually used.
                    my $found = 0;
                    foreach my $pkg (@pkgs) {
                        if ($pkg eq $pkgfrom) {
                            $packages{$pkgfrom} = 1;
                            $found = 1;
                            last;
                        }
                    }
                    if (!$found) {
                        carp(
"Something wicked happened to the output of dpkg -S $curfile"
                        );
                    }
                }
                # Prepare for the next round
                last;
            }
        }
    }

    return keys %packages;
}

# Return a list of packages whose status entries match a given pattern

sub PackagesMatch ($) {
    my $match   = $_[0];
    my @matches = ();

    my $fout = FileHandle->new;
    my $pid  = spawn(
        exec    => ['dpkg', '--status'],
        to_pipe => $fout
    );
    unless (defined $pid) {
        croak("Unable to run \"dpkg --status\": $!");
    }

    my $ctrl;
    while (defined($ctrl = Dpkg::Control->new())
        && $ctrl->parse($fout, 'dpkg --status')) {
        if ("$ctrl" =~ m/$match/m) {
            my $package = $ctrl->{Package};
            if ($ctrl->{Architecture} ne 'all' && multiarch) {
                $package .= ":$ctrl->{Architecture}";
            }
            push @matches, $package;
        }
        undef $ctrl;
    }

    wait_child($pid, cmdline => 'dpkg --status', nocheck => 1);
    return @matches;
}

# Which packages are installed (Package and Source)?

sub InstalledPackages ($) {
    my $source = $_[0];

    my $fout = FileHandle->new;
    my $pid  = spawn(
        exec    => ['dpkg', '--status'],
        to_pipe => $fout
    );
    unless (defined $pid) {
        croak("Unable to run \"dpkg --status\": $!");
    }

    my $ctrl;
    my %matches;
    while (defined($ctrl = Dpkg::Control->new(type => CTRL_FILE_STATUS))
        && $ctrl->parse($fout, 'dpkg --status')) {
        if ($ctrl->{Status} !~ /^install\s+ok\s+installed$/) {
            next;
        }
        if ($source) {
            if (exists $ctrl->{Source}) {
                $matches{ $ctrl->{Source} } = 1;
            }
        }
        if (exists $ctrl->{Package}) {
            $matches{ $ctrl->{Package} } = 1;
            if ($ctrl->{Architecture} ne 'all' && multiarch) {
                $matches{"$ctrl->{Package}:$ctrl->{Architecture}"} = 1;
            }
        }
        undef $ctrl;
    }

    wait_child($pid, cmdline => 'dpkg --status', nocheck => 1);

    return \%matches;
}

1;

=head1 AUTHOR

Bill Allombert <ballombe@debian.org>

=head1 COPYING

Copyright 2001 Bill Allombert <ballombe@debian.org>
Modifications copyright 2002 Julian Gilbey <jdg@debian.org>
dpkg-depcheck is free software, covered by the GNU General Public License, and
you are welcome to change it and/or distribute copies of it under
certain conditions.  There is absolutely no warranty for dpkg-depcheck.

=cut