Debian::AptContents - parse/search through apt-file's Contents files

    my $c = Debian::AptContents->new( { homedir => '~/.dh-make-perl' } );
    my @pkgs = $c->find_file_packages('/usr/bin/foo');
    my $dep = $c->find_perl_module_package('Foo::Bar');

package Debian::AptContents;

use strict;
use warnings;

use base qw(Class::Accessor);
__PACKAGE__->mk_accessors(
    qw(
        cache homedir cache_file contents_dir contents_files verbose
        source sources dist
        )
);

use Config;
use Debian::Dependency;
use DhMakePerl::Utils qw(find_core_perl_dependency);
use File::Spec::Functions qw( catfile catdir splitpath );
use IO::Uncompress::Gunzip;
use List::MoreUtils qw(uniq);
use Module::CoreList ();
use Storable;
use AptPkg::Config;

$AptPkg::Config::_config->init();

our $oldstable_perl = '5.8.8';

sub new {
    my $class = shift;
    $class = ref($class) if ref($class);
    my $self = $class->SUPER::new(@_);

    # required options
    $self->homedir
        or die "No homedir given";

    # some defaults
    $self->contents_dir('/var/cache/apt/apt-file')
        unless $self->contents_dir;
    $self->sources( [ $self->sources ] )
        if $self->sources and not ref( $self->sources );
    $self->sources(
        [   $AptPkg::Config::_config->get_file('Dir::Etc::sourcelist'),
            glob(
                $AptPkg::Config::_config->get_dir('Dir::Etc::sourceparts')
                    . '/*.list'
            )
        ]
    ) unless defined( $self->sources );
    $self->contents_files( $self->get_contents_files )
        unless $self->contents_files;
    $self->cache_file( catfile( $self->homedir, 'Contents.cache' ) )
        unless $self->cache_file;
    $self->verbose(1) unless defined( $self->verbose );

    $self->read_cache();

    return $self;
}

sub warning {
    my ( $self, $level, $msg ) = @_;

    warn "$msg\n" if $self->verbose >= $level;
}

sub repo_source_to_contents_path {
    my ( $self, $source ) = @_;

    my ( $schema, $uri, $dist, @extra ) = split /\s+/, $source;
    my ( $proto, $host, $port, $dir ) = $uri =~ m{
		^
                (?:([^:/?\#]+):)?                      # proto
                (?://
                                ([^:/?\#]*)                    # host
                                (?::(\d+))?                    # port
                )?
                ([^?\#]*)                              # path
        }x;

    unless ( defined $schema ) {
        $self->warning( 1, "'$_' has unknown format" );
        next;
    }

    return unless $schema eq 'deb';

    if ( $self->dist ) {
        if ( $self->dist =~ /^\s*{\s*(.+)\s*}\s*$/ ) {
            return unless grep {/^$dist$/} split( /\s*,\s*/, $1 );
        }
        else {
            return if $dist ne $self->dist;
        }
    }

    $host ||= '';    # set empty string if $host is undef
    $dir  ||= '';    # deb http://there sid main

    s{/$}{}  for ( $host, $dir, $dist );    # remove trailing /
    s{^/}{}  for ( $host, $dir, $dist );    # remove initial /
    s{/}{_}g for ( $host, $dir, $dist );    # replace remaining /

    return ( $host . "_" . join( "_", $dir || (), "dists", $dist ) );
}

sub get_contents_files {
    my $self = shift;

    my $archspec = `dpkg --print-architecture`;
    chomp($archspec);

    my @res;

    for my $s ( @{ $self->sources } ) {
        # by default ->sources contains a list of files that APT would look
        # at. Some of them may not exist, so do not fail if this is the case
        next unless -e $s;

        my $src = IO::File->new( $s, 'r' )
            or die "Unable to open '$s': $!\n";

        while (<$src>) {
            chomp;
            s/#.*//;
            s/^\s+//;
            s/\s+$//;
            next unless $_;

            my $path = $self->repo_source_to_contents_path($_);

            next unless $path;

            # try all of with/out architecture and
            # un/compressed
            for my $a ( '', "-$archspec" ) {
                for my $c ( '', '.gz' ) {
                    my $f = catfile( $self->contents_dir,
                        "${path}_Contents$a$c", );
                    push @res, $f if -e $f;
                }
            }
        }
    }

    return [ uniq sort @res ];
}

sub read_cache {
    my $self = shift;

    my $cache;

    if ( -r $self->cache_file ) {
        $cache = eval { Storable::retrieve( $self->cache_file ) };
        undef($cache) unless ref($cache) and ref($cache) eq 'HASH';
    }

    # see if the cache is stale
    if ( $cache and $cache->{stamp} and $cache->{contents_files} ) {
        undef($cache)
            unless join( '><', @{ $self->contents_files } ) eq
                join( '><', @{ $cache->{contents_files} } );

        # file lists are the same?
        # see if any of the files has changed since we
        # last read it
        if ($cache) {
            for ( @{ $self->contents_files } ) {
                if ( ( stat($_) )[9] > $cache->{stamp} ) {
                    undef($cache);
                    last;
                }
            }
        }
    }
    else {
        undef($cache);
    }

    unless ($cache) {
        $self->source('parsed files');
        $cache->{stamp}          = time;
        $cache->{contents_files} = [];
        $cache->{apt_contents}   = {};
        for ( @{ $self->contents_files } ) {
            push @{ $cache->{contents_files} }, $_;
            my $f
                = /\.gz$/
                ? IO::Uncompress::Gunzip->new($_)
                : IO::File->new( $_, 'r' );

            unless ($f) {
                warn "Error reading '$_': $!\n";
                next;
            }

            $self->warning( 1, "Parsing $_ ..." );
            my $capturing = 0;
            my $line;
            while ( defined( $line = $f->getline ) ) {
                if ($capturing) {
                    my ( $file, $packages ) = split( /\s+/, $line );
                    next unless $file =~ s{
                                                ^usr/
                                                (?:share|lib)/
                                                (?:perl\d+/             # perl5/
                                                | perl/(?:\d[\d.]+)/   # or perl/5.10/
                                                )
                                        }{}x;
                    $cache->{apt_contents}{$file} = $packages;

                    # $packages is a comma-separated list of
                    # section/package items. We'll parse it when a file
                    # matches. Otherwise we'd parse thousands of entries,
                    # while checking only a couple
                }
                else {
                    $capturing = 1 if $line =~ /^FILE\s+LOCATION/;
                }
            }
        }

        if ( %{ $cache->{apt_contents} } ) {
            $self->cache($cache);
            $self->store_cache;
        }
    }
    else {
        $self->source('cache');
        $self->warning( 1,
            "Using cached Contents from " . localtime( $cache->{stamp} ) );

        $self->cache($cache);
    }
}

sub store_cache {
    my $self = shift;

    my ( $vol, $dir, $file ) = splitpath( $self->cache_file );

    $dir = catdir( $vol, $dir );
    unless ( -d $dir ) {
        mkdir $dir
            or die "Error creating directory '$dir': $!\n";
    }

    Storable::store( $self->cache, $self->cache_file . '-new' );
    rename( $self->cache_file . '-new', $self->cache_file );
}

sub find_file_packages {
    my ( $self, $file ) = @_;

    my $packages = $self->cache->{apt_contents}{$file};

    return () unless $packages;

    my @packages = split( /,/, $packages );    # Contents contains a
                                               # comma-delimitted list
                                               # of packages

    s{.+/}{} for @packages;                    # remove section. Greedy on purpose
                                               # otherwise it won't strip enough off Ubuntu's
                                               # usr/share/perl5/Config/Any.pm  universe/perl/libconfig-any-perl

    return @packages;
}

sub find_perl_module_package {
    my ( $self, $module, $version ) = @_;

    # see if the module is included in perl core
    my $core_dep = find_core_perl_dependency( $module, $version );

    # try module packages
    my $module_file = $module;
    $module_file =~ s|::|/|g;

    my @matches = $self->find_file_packages("$module_file.pm");

    # rank non -perl packages lower
    @matches = sort {
        if    ( $a !~ /-perl$/ ) { return 1; }
        elsif ( $b !~ /-perl$/ ) { return -1; }
        else                     { return $a cmp $b; }    # or 0?
    } @matches;

    # we don't want perl, perl-base and perl-modules here
    @matches = grep { !/^perl(?:-(?:base|modules))?$/ } @matches;

    my $direct_dep;
    $direct_dep = Debian::Dependency->new(
          ( @matches > 1 )
        ? [ map ( { pkg => $_, rel => '>=', ver => $version }, @matches ) ]
        : ( $matches[0], $version )
    ) if @matches;

    my $running_perl = $Config::Config{version};

    if ($core_dep) {

        # the core dependency is satosfied by oldstable?
        if ( $core_dep->ver <= $oldstable_perl ) {
            # drop the direct dependency and remove the version
            undef($direct_dep);

            $core_dep->ver(undef);
            $core_dep->rel(undef);
        }

        if ($direct_dep) {
            # both in core and in a package.
            if( $running_perl >= $core_dep->ver ) {
                return Debian::Dependency->new("$core_dep | $direct_dep");
            }
            else {
                return Debian::Dependency->new("$direct_dep | $core_dep");
            }
        }
        else {
            # only in core
            return $core_dep;
        }
    }
    else {
        # maybe in a package
        return $direct_dep;
    }
}

1;