File Coverage

blib/lib/CPAN/Common/Index/Mirror.pm
Criterion Covered Total %
statement 140 141 99.2
branch 61 76 80.2
condition 6 6 100.0
subroutine 26 26 100.0
pod 4 7 57.1
total 237 256 92.5


line stmt bran cond sub pod time code
1 4     4   3113 use 5.008001;
  4         13  
2 4     4   17 use strict;
  4         9  
  4         69  
3 4     4   20 use warnings;
  4         8  
  4         168  
4              
5             package CPAN::Common::Index::Mirror;
6             # ABSTRACT: Search index via CPAN mirror flatfiles
7              
8             our $VERSION = '0.009'; # TRIAL
9              
10 4     4   23 use parent 'CPAN::Common::Index';
  4         8  
  4         22  
11              
12 4     4   177 use Class::Tiny qw/cache mirror/;
  4         9  
  4         13  
13              
14 4     4   1007 use Carp;
  4         8  
  4         192  
15 4     4   1404 use CPAN::DistnameInfo;
  4         2914  
  4         97  
16 4     4   23 use File::Basename ();
  4         8  
  4         53  
17 4     4   1984 use File::Fetch;
  4         201969  
  4         137  
18 4     4   32 use File::Temp 0.19; # newdir
  4         86  
  4         268  
19 4     4   1806 use Search::Dict 1.07;
  4         2907  
  4         174  
20 4     4   1378 use Tie::Handle::SkipHeader;
  4         11338  
  4         95  
21 4     4   1640 use URI;
  4         14135  
  4         2050  
22              
23             our $HAS_IO_UNCOMPRESS_GUNZIP = eval { require IO::Uncompress::Gunzip };
24              
25             #pod =attr mirror
26             #pod
27             #pod URI to a CPAN mirror. Defaults to C.
28             #pod
29             #pod =attr cache
30             #pod
31             #pod Path to a local directory to store copies of the source indices. Defaults to a
32             #pod temporary directory if not specified.
33             #pod
34             #pod =cut
35              
36             sub BUILD {
37 30     30 0 221617 my $self = shift;
38              
39             # cache directory needs to exist
40 30         733 my $cache = $self->cache;
41 30 100       262 $cache = File::Temp->newdir
42             unless defined $cache;
43 30 50       2257 if ( !-d $cache ) {
44 0         0 Carp::croak("Cache directory '$cache' does not exist");
45             }
46 30         1060 $self->cache($cache);
47              
48             # ensure mirror URL ends in '/'
49 30         536 my $mirror = $self->mirror;
50 30 100       222 $mirror = "http://www.cpan.org/"
51             unless defined $mirror;
52 30         137 $mirror =~ s{/?$}{/};
53 30         460 $self->mirror($mirror);
54              
55 30         167 return;
56             }
57              
58             my %INDICES = (
59             mailrc => 'authors/01mailrc.txt.gz',
60             packages => 'modules/02packages.details.txt.gz',
61             );
62              
63             # XXX refactor out from subs below
64             my %TEST_GENERATORS = (
65             regexp_nocase => sub {
66             my $arg = shift;
67             my $re = ref $arg eq 'Regexp' ? $arg : qr/\A\Q$arg\E\z/i;
68             return sub { $_[0] =~ $re };
69             },
70             regexp => sub {
71             my $arg = shift;
72             my $re = ref $arg eq 'Regexp' ? $arg : qr/\A\Q$arg\E\z/;
73             return sub { $_[0] =~ $re };
74             },
75             version => sub {
76             my $arg = shift;
77             my $v = version->parse($arg);
78             return sub {
79             eval { version->parse( $_[0] ) == $v };
80             };
81             },
82             );
83              
84             my %QUERY_TYPES = (
85             # package search
86             package => 'regexp',
87             version => 'version',
88             dist => 'regexp',
89              
90             # author search
91             id => 'regexp_nocase', # XXX need to add "alias " first
92             fullname => 'regexp_nocase',
93             email => 'regexp_nocase',
94             );
95              
96             sub cached_package {
97 31     31 0 2200 my ($self) = @_;
98             my $package = File::Spec->catfile( $self->cache,
99 31         864 File::Basename::basename( $INDICES{packages} ) );
100 31         1825 $package =~ s/\.gz$//;
101 31 100       632 $self->refresh_index unless -r $package;
102 31         109 return $package;
103             }
104              
105             sub cached_mailrc {
106 10     10 0 24 my ($self) = @_;
107             my $mailrc =
108 10         326 File::Spec->catfile( $self->cache, File::Basename::basename( $INDICES{mailrc} ) );
109 10         727 $mailrc =~ s/\.gz$//;
110 10 100       251 $self->refresh_index unless -r $mailrc;
111 10         46 return $mailrc;
112             }
113              
114             sub refresh_index {
115 12     12 1 2241 my ($self) = @_;
116 12         46 for my $file ( values %INDICES ) {
117 24         313110 my $remote = URI->new_abs( $file, $self->mirror );
118 24 100       18951 $remote =~ s/\.gz$//
119             unless $HAS_IO_UNCOMPRESS_GUNZIP;
120 24         372 my $ff = File::Fetch->new( uri => $remote );
121 24 50       74253 my $where = $ff->fetch( to => $self->cache )
122             or Carp::croak( $ff->error );
123 24 100       270830 if ($HAS_IO_UNCOMPRESS_GUNZIP) {
124 14         150 ( my $uncompressed = $where ) =~ s/\.gz$//;
125 4     4   29 no warnings 'once';
  4         8  
  4         3472  
126 14 50       118 IO::Uncompress::Gunzip::gunzip( $where, $uncompressed )
127             or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
128             }
129             }
130 12         5141281 return 1;
131             }
132              
133             # epoch secs
134             sub index_age {
135 4     4 1 1981 my ($self) = @_;
136 4         22 my $package = $self->cached_package;
137 4 50       76 return ( -r $package ? ( stat($package) )[9] : 0 ); # mtime if readable
138             }
139              
140             sub search_packages {
141 51     51 1 25954 my ( $self, $args ) = @_;
142 51 50       185 Carp::croak("Argument to search_packages must be hash reference")
143             unless ref $args eq 'HASH';
144              
145 51         158 my $index_path = $self->cached_package;
146 51 50       540 die "Can't read $index_path" unless -r $index_path;
147              
148 51         334 my $fh = IO::Handle->new;
149 51 50       1494 tie *$fh, 'Tie::Handle::SkipHeader', "<", $index_path
150             or die "Can't tie $index_path: $!";
151              
152             # Convert scalars or regexps to subs
153 51         5705 my $rules;
154 51         276 while ( my ( $k, $v ) = each %$args ) {
155 56         158 $rules->{$k} = _rulify( $k, $v );
156             }
157              
158 51         102 my @found;
159 51 100 100     271 if ( $args->{package} and ref $args->{package} eq '' ) {
160             # binary search 02packages on package
161 36         184 my $pos = look $fh, $args->{package}, { xfrm => \&_xform_package, fold => 1 };
162 36 50       1052 return if $pos == -1;
163             # loop over any case-insensitive matching lines
164 36         98 LINE: while ( my $line = <$fh> ) {
165 76 100       1051 last unless $line =~ /\A\Q$args->{package}\E\s+/i;
166 42         128 push @found, _match_package_line( $line, $rules );
167             }
168             }
169             else {
170             # iterate all lines looking for match
171 15         58 LINE: while ( my $line = <$fh> ) {
172 778635         4417631 push @found, _match_package_line( $line, $rules );
173             }
174             }
175 51 100       1309 return wantarray ? @found : $found[0];
176             }
177              
178             sub search_authors {
179 10     10 1 10499 my ( $self, $args ) = @_;
180 10 50       43 Carp::croak("Argument to search_authors must be hash reference")
181             unless ref $args eq 'HASH';
182              
183 10         39 my $index_path = $self->cached_mailrc;
184 10 50       157 die "Can't read $index_path" unless -r $index_path;
185 10 50       311 open my $fh, $index_path or die "Can't open $index_path: $!";
186              
187             # Convert scalars or regexps to subs
188 10         31 my $rules;
189 10         78 while ( my ( $k, $v ) = each %$args ) {
190 10         40 $rules->{$k} = _rulify( $k, $v );
191             }
192              
193 10         21 my @found;
194 10 100 100     63 if ( $args->{id} and ref $args->{id} eq '' ) {
195             # binary search mailrec on package
196 4         32 my $pos = look $fh, $args->{id}, { xfrm => \&_xform_mailrc, fold => 1 };
197 4 50       72 return if $pos == -1;
198 4         27 my $line = <$fh>;
199 4         17 push @found, _match_mailrc_line( $line, $rules );
200             }
201             else {
202             # iterate all lines looking for match
203 6         76 LINE: while ( my $line = <$fh> ) {
204 31722         61753 push @found, _match_mailrc_line( $line, $rules );
205             }
206             }
207 10 100       318 return wantarray ? @found : $found[0];
208             }
209              
210             sub _rulify {
211 66     66   143 my ( $key, $arg ) = @_;
212 66 50       206 return $arg if ref($arg) eq 'CODE';
213 66         285 return $TEST_GENERATORS{ $QUERY_TYPES{$key} }->($arg);
214             }
215              
216             sub _xform_package {
217 1092     1092   32979 my @fields = split " ", $_[0], 2;
218 1092         2280 return $fields[0];
219             }
220              
221             sub _xform_mailrc {
222 52     52   1062 my @fields = split " ", $_[0], 3;
223 52         116 return $fields[1];
224             }
225              
226             sub _match_package_line {
227 778677     778677   1261439 my ( $line, $rules ) = @_;
228 778677 50       1495836 return unless defined $line;
229 778677         1894993 my ( $mod, $version, $dist, $comment ) = split " ", $line, 4;
230 778677 100       1721856 if ( $rules->{package} ) {
231 519132 100       878236 return unless $rules->{package}->($mod);
232             }
233 259616 100       493225 if ( $rules->{version} ) {
234 38 100       103 return unless $rules->{version}->($version);
235             }
236 259583 100       509729 if ( $rules->{dist} ) {
237 259545 100       442730 return unless $rules->{dist}->($dist);
238             }
239 43         210 $dist =~ s{\A./../}{};
240             return {
241 43         298 package => $mod,
242             version => $version,
243             uri => "cpan:///distfile/$dist",
244             };
245             }
246              
247             sub _match_mailrc_line {
248 31726     31726   56089 my ( $line, $rules ) = @_;
249 31726 50       61517 return unless defined $line;
250 31726         98986 my ( $id, $address ) = $line =~ m{\Aalias\s+(\S+)\s+"(.*)"};
251 31726         102534 my ( $fullname, $email ) = $address =~ m{([^<]+)<([^>]+)>};
252 31726         106803 $fullname =~ s/\s*$//;
253 31726 100       73484 if ( $rules->{id} ) {
254 10578 100       18822 return unless $rules->{id}->($id);
255             }
256 21154 100       41899 if ( $rules->{fullname} ) {
257 10574 100       18342 return unless $rules->{fullname}->($fullname);
258             }
259 10582 100       20555 if ( $rules->{email} ) {
260 10574 100       17968 return unless $rules->{email}->($email);
261             }
262             return {
263 10         80 id => $id,
264             fullname => $fullname,
265             email => $email,
266             };
267             }
268              
269             1;
270              
271              
272             # vim: ts=4 sts=4 sw=4 et:
273              
274             __END__