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


line stmt bran cond sub pod time code
1             package Dist::Util::Debian;
2              
3             our $DATE = '2017-01-17'; # DATE
4             our $VERSION = '0.005'; # VERSION
5              
6 1     1   12782 use 5.010001;
  1         2  
7 1     1   3 use strict;
  1         1  
  1         16  
8 1     1   2 use warnings;
  1         1  
  1         597  
9              
10             require Exporter;
11             our @ISA = qw(Exporter);
12             our @EXPORT_OK = qw(
13             dist2deb
14             deb_exists
15             dist_has_deb
16             deb_ver
17             dist_deb_ver
18             );
19              
20             sub dist2deb {
21 1     1 1 7 my $dist = shift;
22 1         10 return "lib" . lc($dist) . "-perl";
23             }
24              
25             sub _deb_exists_or_deb_ver {
26 0     0     require HTTP::Tiny;
27              
28 0           my $which = shift;
29 0 0         my $opts = ref($_[0]) eq 'HASH' ? shift : {};
30              
31 0 0         if ($opts->{use_allpackages}) {
32 0           require File::Slurper::Temp;
33 0           require File::Util::Tempdir;
34 0           require IO::Uncompress::Gunzip;
35 0           my $url = "https://packages.debian.org/unstable/allpackages?format=txt.gz";
36 0           my $path = File::Util::Tempdir::get_tempdir() . "/allpackages.txt";
37 0           my @stat = stat($path);
38 0 0 0       unless (@stat && $stat[9] > time() - 86400) {
39 0           my $res = HTTP::Tiny->new->get($url);
40 0 0         unless ($res->{success}) {
41 0           warn "Can't download $url: $res->{status} - $res->{reason}";
42 0           return undef;
43             }
44 0           my $uncompressed = "";
45 0 0         IO::Uncompress::Gunzip::gunzip(\($res->{content}), \$uncompressed)
46             or die "gunzip failed: $IO::Uncompress::Gunzip::GunzipError";
47 0           File::Slurper::Temp::write_text($path, $uncompressed);
48             }
49 0           my %versions;
50 0           my $re = join("|", map { quotemeta($_) } @_); $re = qr/^($re) \(([^\)]+)\)/;
  0            
  0            
51 0 0         open my($fh), "<", $path or die "Can't open $path: $!";
52 0           while (defined(my $line = <$fh>)) {
53 0 0         if ($line =~ $re) {
54 0           $versions{$1} = $2;
55             }
56             }
57 0 0         return map { $which eq 'deb_exists' ? (defined $versions{$_} ? 1:0) : $versions{$_} } @_;
  0 0          
58             } else {
59 0           my @res;
60 0           for my $deb (@_) {
61 0           my $url = "https://packages.debian.org/sid/$deb";
62 0           my $res = HTTP::Tiny->new->get($url);
63 0 0         unless ($res->{success}) {
64 0           warn "Can't check $url: $res->{status} - $res->{reason}";
65 0           push @res, undef;
66 0           next;
67             }
68 0 0         if ($res->{content} =~ /No such package/) {
    0          
69 0 0         push @res, $which eq 'deb_exists' ? 0 : undef;
70 0           next;
71             } elsif ($res->{content} =~ /Package: \Q$deb\E \(([^\)]+)\)/) {
72 0 0         push @res, $which eq 'deb_exists' ? 1 : $1;
73 0           next;
74             } else {
75 0           warn "Can't understand the content of $url, no indication of ".
76             "package exists or doesn't exist";
77 0           push @res, undef;
78 0           next;
79             }
80             }
81 0           return @res;
82             }
83             }
84              
85             sub deb_exists {
86 0     0 1   _deb_exists_or_deb_ver('deb_exists', @_);
87             }
88              
89             sub deb_ver {
90 0     0 1   _deb_exists_or_deb_ver('deb_ver', @_);
91             }
92              
93             sub dist_has_deb {
94 0 0   0 1   my $opts = ref($_[0]) eq 'HASH' ? shift : {};
95              
96 0           deb_exists($opts, map { dist2deb($_) } @_);
  0            
97             }
98              
99             sub dist_deb_ver {
100 0 0   0 1   my $opts = ref($_[0]) eq 'HASH' ? shift : {};
101              
102 0           deb_ver($opts, map { dist2deb($_) } @_);
  0            
103             }
104              
105             1;
106             # ABSTRACT: Utilities related to Perl distribution and Debian
107              
108             __END__