File Coverage

blib/lib/Alien/Packages/Dpkg.pm

Criterion	Covered	Total	%
statement	42	42	100.0
branch	10	14	71.4
condition	1	2	50.0
subroutine	6	6	100.0
pod	3	3	100.0
total	62	67	92.5

package Alien::Packages::Dpkg;

use strict;
use warnings;
use vars qw($VERSION @ISA);

=head1 NAME

Alien::Packages::Dpkg - get's information from Debian's package database via dpkg-query

=cut

$VERSION = "0.003";

require Alien::Packages::Base;

@ISA = qw(Alien::Packages::Base);

=head1 ISA

    Alien::Packages::Rpm
    ISA Alien::Packages::Base

=cut

require IPC::Cmd;

my $dpkg_query;

=head1 SUBROUTINES/METHODS

=head2 usable

Returns true when the C command could be found in the path.

=cut

sub usable
{
    unless ( defined($dpkg_query) )
    {
        $dpkg_query = IPC::Cmd::can_run('dpkg-query');
        $dpkg_query ||= '';
    }

    return $dpkg_query;
}

=head2 list_packages

Returns the list of installed I packages.

=cut

sub list_packages
{
    my $self = $_[0];
    my @packages;

    my ( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
      $self->_run_ipc_cmd(
                     command => [ $dpkg_query, '-W', q(-f=${Package}:${Version}:${Description}\n) ],
                     verbose => 0, );

    if ($success)
    {
        chomp $stdout_buf->[0];
        my @pkglist = split( /\n/, $stdout_buf->[0] );
        my %pkg_details;
        foreach my $pkg (@pkglist)
        {
            if ( 0 == index( $pkg, ' ' ) )
            {
                push( @{ $pkg_details{Description} }, $pkg );
            }
            else
            {
                %pkg_details and push( @packages, {%pkg_details} );
                @pkg_details{ 'Package', 'Version', 'Summary' } = split( ':', $pkg );
                $pkg_details{Description} = [];
            }
        }
        %pkg_details and push( @packages, {%pkg_details} );
    }

    return @packages;
}

=head2 list_fileowners

Returns the I packages which are associated to requested file(s).

=cut

sub list_fileowners
{
    my ( $self, @files ) = @_;
    my %file_owners;

    foreach my $file (@files)
    {
        my ( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
          $self->_run_ipc_cmd( command => [ $dpkg_query, '-S', $file ],
                               verbose => 0, );

        if ($success)
        {
            chomp $stdout_buf->[0];
            my @pkglist = split( /\n/, $stdout_buf->[0] );
            foreach my $pkg (@pkglist)
            {
                if ( my ( $pkg_names, $fn ) = $pkg =~ m/^([^:]+):\s+([^\s].*)$/ )
                {
                    foreach my $pkg_name (split /\s*,\s*/, $pkg_names)
                    {
                        push( @{ $file_owners{$fn} }, { Package => $pkg_name } );
                    }
                }
            }
        }
    }

    return %file_owners;
}

=head1 AUTHOR

Jens Rehsack, C<<  >>

=head1 LICENSE AND COPYRIGHT

Copyright 2010 Jens Rehsack.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1;