File Coverage

blib/lib/Dist/Util/Debian.pm

Criterion	Covered	Total	%
statement	10	63	15.8
branch	0	32	0.0
condition	0	3	0.0
subroutine	4	9	44.4
pod	5	5	100.0
total	19	112	16.9

package Dist::Util::Debian;

our $DATE = '2017-01-17'; # DATE
our $VERSION = '0.005'; # VERSION

use 5.010001;
use strict;
use warnings;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
                       dist2deb
                       deb_exists
                       dist_has_deb
                       deb_ver
                       dist_deb_ver
               );

sub dist2deb {
    my $dist = shift;
    return "lib" . lc($dist) . "-perl";
}

sub _deb_exists_or_deb_ver {
    require HTTP::Tiny;

    my $which = shift;
    my $opts = ref($_[0]) eq 'HASH' ? shift : {};

    if ($opts->{use_allpackages}) {
        require File::Slurper::Temp;
        require File::Util::Tempdir;
        require IO::Uncompress::Gunzip;
        my $url  = "https://packages.debian.org/unstable/allpackages?format=txt.gz";
        my $path = File::Util::Tempdir::get_tempdir() . "/allpackages.txt";
        my @stat = stat($path);
        unless (@stat && $stat[9] > time() - 86400) {
            my $res = HTTP::Tiny->new->get($url);
            unless ($res->{success}) {
                warn "Can't download $url: $res->{status} - $res->{reason}";
                return undef;
            }
            my $uncompressed = "";
            IO::Uncompress::Gunzip::gunzip(\($res->{content}), \$uncompressed)
                  or die "gunzip failed: $IO::Uncompress::Gunzip::GunzipError";
            File::Slurper::Temp::write_text($path, $uncompressed);
        }
        my %versions;
        my $re = join("|", map { quotemeta($_) } @_); $re = qr/^($re) \(([^\)]+)\)/;
        open my($fh), "<", $path or die "Can't open $path: $!";
        while (defined(my $line = <$fh>)) {
            if ($line =~ $re) {
                $versions{$1} = $2;
            }
        }
        return map { $which eq 'deb_exists' ? (defined $versions{$_} ? 1:0) : $versions{$_} } @_;
    } else {
        my @res;
        for my $deb (@_) {
            my $url = "https://packages.debian.org/sid/$deb";
            my $res = HTTP::Tiny->new->get($url);
            unless ($res->{success}) {
                warn "Can't check $url: $res->{status} - $res->{reason}";
                push @res, undef;
                next;
            }
            if ($res->{content} =~ /No such package/) {
                push @res, $which eq 'deb_exists' ? 0 : undef;
                next;
            } elsif ($res->{content} =~ /Package: \Q$deb\E \(([^\)]+)\)/) {
                push @res, $which eq 'deb_exists' ? 1 : $1;
                next;
            } else {
                warn "Can't understand the content of $url, no indication of ".
                    "package exists or doesn't exist";
                push @res, undef;
                next;
            }
        }
        return @res;
    }
}

sub deb_exists {
    _deb_exists_or_deb_ver('deb_exists', @_);
}

sub deb_ver {
    _deb_exists_or_deb_ver('deb_ver', @_);
}

sub dist_has_deb {
    my $opts = ref($_[0]) eq 'HASH' ? shift : {};

    deb_exists($opts, map { dist2deb($_) } @_);
}

sub dist_deb_ver {
    my $opts = ref($_[0]) eq 'HASH' ? shift : {};

    deb_ver($opts, map { dist2deb($_) } @_);
}

1;
# ABSTRACT: Utilities related to Perl distribution and Debian

__END__