File Coverage

blib/lib/PAUSE/Packages.pm
Criterion Covered Total %
statement 117 136 86.0
branch 23 42 54.7
condition 6 21 28.5
subroutine 22 22 100.0
pod 2 3 66.6
total 170 224 75.8


line stmt bran cond sub pod time code
1             package PAUSE::Packages;
2             $PAUSE::Packages::VERSION = '0.16';
3 5     5   722177 use 5.10.0;
  5         19  
4 5     5   4140 use autodie qw(open);
  5         96281  
  5         25  
5              
6 5     5   243023 use Moo 1.006;
  5         79063  
  5         36  
7              
8 5     5   12192 use CPAN::DistnameInfo;
  5         4699  
  5         145  
9 5     5   27 use Carp;
  5         9  
  5         337  
10 5     5   4765 use File::HomeDir 0.93;
  5         31261  
  5         290  
11 5     5   4078 use File::Spec::Functions 'catfile';
  5         4257  
  5         353  
12 5     5   3075 use HTTP::Date qw(time2str);
  5         12381  
  5         296  
13 5     5   22077 use HTTP::Tiny;
  5         273626  
  5         200  
14 5     5   4263 use JSON::MaybeXS;
  5         40333  
  5         330  
15 5     5   3060 use PAUSE::Packages::Module;
  5         19  
  5         155  
16 5     5   3275 use PAUSE::Packages::Release;
  5         13  
  5         145  
17 5     5   3699 use Safe::Isa;
  5         2038  
  5         672  
18 5     5   3703 use Types::URI -all;
  5         1030545  
  5         80  
19 5     5   12577 use Types::Standard qw( Bool Object Str );
  5         10  
  5         37  
20 5     5   4018 use URI;
  5         10  
  5         117  
21 5     5   3954 use URL::Encode qw( url_encode );
  5         23317  
  5         8073  
22              
23             my $DISTNAME = 'PAUSE-Packages';
24              
25             has from_cache => (
26             is => 'rwp',
27             isa => Bool,
28             init_arg => undef,
29             );
30              
31             has ua => (
32             is => 'ro',
33             isa => Object,
34             default => sub { return HTTP::Tiny->new },
35             );
36              
37             has url => (
38             is => 'ro',
39             isa => Uri,
40             coerce => 1,
41             default =>
42             sub { return 'http://www.cpan.org/modules/02packages.details.txt' },
43             );
44              
45             has path => (
46             is => 'rw',
47             isa => Str,
48             );
49              
50             sub release_iterator
51             {
52 2     2 1 2068 my $self = shift;
53              
54 2         1346 require PAUSE::Packages::ReleaseIterator;
55 2         11 return PAUSE::Packages::ReleaseIterator->new( packages => $self, @_ );
56             }
57              
58             sub release
59             {
60 3     3 1 1778 my $self = shift;
61 3         10 my $distname = shift;
62 3         5 my $fh;
63 3         7 local $_;
64              
65 3         97 open($fh, '<', $self->path);
66 3         2378 while (<$fh>) {
67 10 100       59 last if /^$/;
68             }
69 3         15 while (<$fh>) {
70 3         9 chomp;
71 3         21 my ($path, $json) = split(/\s+/, $_, 2);
72 3         29 my $di = CPAN::DistnameInfo->new($path);
73 3 50 33     274 next RELEASE if !defined($di) || !defined($di->dist);
74 3 100       41 last if $di->dist gt $distname;
75 2 50       21 if ($di->dist eq $distname) {
76 2         17 my $modules = [];
77 2         6 foreach my $entry (@{ decode_json($json) }) {
  2         45  
78 2         27 my $module = PAUSE::Packages::Module->new(
79             name => $entry->[0],
80             version => $entry->[1],
81             );
82 2         3081 push(@$modules, $module);
83             }
84 2         26 return PAUSE::Packages::Release->new(
85             modules => $modules,
86             path => $path,
87             distinfo => $di,
88             );
89             }
90             }
91 1         25 close($fh);
92 1         6 return undef;
93             }
94              
95             sub BUILD
96             {
97 5     5 0 33178 my $self = shift;
98              
99             # If constructor didn't specify a local file, then mirror the file from CPAN
100 5 100       53 if (not $self->path) {
101             # use a file name which is unique to the URI
102 2         1072 my $cache_file_name = url_encode( $self->url );
103              
104 2         126 $self->path( catfile(File::HomeDir->my_dist_data( $DISTNAME, { create => 1 } ), $cache_file_name) );
105 2         9145 $self->_cache_file_if_needed();
106             }
107             }
108              
109             sub _cache_file_if_needed
110             {
111 2     2   5 my $self = shift;
112 2 50       16 my $options = $self->ua->$_isa( 'HTTP::Tiny' ) ? {} : [];
113              
114 2         94 my $cache_creation_time = (stat($self->path))[9];
115              
116 2 50       114 if (-f $self->path) {
117 0 0       0 if ( $self->ua->$_isa( 'HTTP::Tiny' ) ) {
118 0         0 $options->{headers}->{'If-Modified-Since'}
119             = time2str( $cache_creation_time );
120             }
121             else {
122 0         0 $options = [ 'If-Modified-Since' => time2str( $cache_creation_time ) ];
123             }
124              
125 0         0 my $uri = $self->url;
126 0 0       0 $uri->scheme( 'file' ) if !$uri->scheme;
127              
128 0 0 0     0 if ( $uri->scheme eq 'file'
      0        
129             && -f $uri->path
130             && ( stat( $uri->path ) )[9] < $cache_creation_time )
131             {
132 0         0 $self->_set_from_cache( 1 );
133 0         0 return;
134             }
135             }
136              
137             my $response = $self->ua->get( $self->url,
138 2 50       54 $self->ua->$_isa( 'HTTP::Tiny' ) ? $options : @{$options} );
  2         34  
139              
140 2 50       292029 my $status = $response->$_can('code') ? $response->code : $response->{status};
141 2 50       58 if ( $status == 304) { ; # Not Modified
142 0         0 $self->_set_from_cache( 1 );
143 0         0 return;
144             }
145              
146 2 100       8 if ($status == 200) {
147             $self->_transform_and_cache( $response->$_can('content')
148             ? $response->content
149 1 50       5 : $response->{content} );
150 1         13 $self->_set_from_cache ( 0 );
151 1         1498 return;
152             }
153              
154 1 50       4 my $reason = $response->$_can('message') ? $response->message : $response->{reason};
155 1         224 croak("request for 02packages failed: $status $reason");
156             }
157              
158             sub _transform_and_cache
159             {
160 1     1   31 my ($self, $content) = @_;
161 1         2 my $inheader = 1;
162 1         3 my (%release, %other, $module, $version, $path, $distname);
163              
164             LINE:
165 1         9 while ($content =~ m!^(.*)$!gm) {
166 3         8 my $line = $1;
167 3 100 66     20 if ($line =~ /^$/ && $inheader) {
168 1         2 $inheader = 0;
169 1         6 next;
170             }
171 2 100       11 next LINE if $inheader;
172 1         6 ($module, $version, $path) = split(/\s+/, $line);
173              
174 1         16 my $di = CPAN::DistnameInfo->new($path);
175              
176 1 50 33     97 if (defined($di) && defined($distname = $di->dist) && defined($di->version)) {
      33        
177 1 50 33     24 if (!exists($release{$distname}) || $release{$distname}->{version} lt $di->version) {
    0          
178 1         4 $release{$distname} = {
179             version => $di->version,
180             modules => [ { name => $module, version => $version } ],
181             path => $path,
182             };
183             } elsif ($di->version lt $release{$distname}->{version}) {
184 0         0 next LINE;
185             } else {
186 0         0 push(@{ $release{$distname}->{modules} },
  0         0  
187             { name => $module, version => $version }
188             );
189             }
190             } else {
191 0         0 push(@{ $other{$path} }, { name => $module, version => $version });
  0         0  
192             }
193             }
194              
195 1         65 open(my $fh, '>', $self->path);
196              
197 1         3784 print $fh <<"END_HEADER";
198             File: PAUSE Packages data
199             Format: 2
200             Source: CPAN/modules/02packages.details.txt
201              
202             END_HEADER
203              
204 1         10 foreach $distname (sort keys %release) {
205 1         5 print $fh $release{$distname}->{path}, ' ';
206 1         5 print $fh "[", join(",", map { '["'.$_->{name}.'","'.$_->{version}.'"]' } @{ $release{$distname}->{modules} }), "]\n";
  1         14  
  1         7  
207             }
208              
209 1         6 foreach my $release (sort keys %other) {
210 0         0 print $fh $release, ' ';
211 0         0 print $fh "[", join(",", map { '["'.$_->{name}.'","'.$_->{version}.'"]' } @{ $other{$release} }), "]\n";
  0         0  
  0         0  
212             }
213              
214 1         89 close($fh);
215             }
216              
217             1;
218              
219             =head1 NAME
220              
221             PAUSE::Packages - interface to PAUSE's packages file (02packages.details.txt)
222              
223             =head1 SYNOPSIS
224              
225             use PAUSE::Packages 0.12;
226              
227             my $pp = PAUSE::Packages->new;
228             my $iterator = $pp->release_iterator();
229              
230             while (my $release = $iterator->next_release) {
231             print 'path = ', $release->path, "\n";
232             print ' modules = ', join(', ', @{ $release->modules }), "\n";
233             }
234              
235             $release = $pp->release('Module-Path');
236              
237             # to parse a local file
238             my $pp = PAUSE::Packages->new(
239             url => 'file:///path/to/02packages.details.txt',
240             ua => LWP::UserAgent->new,
241             );
242              
243             =head1 DESCRIPTION
244              
245             B<NOTE>: this is very much an alpha release. any and all feedback appreciated.
246              
247             PAUSE::Packages provides an interface to the C<02packages.details.txt>
248             file produced by the Perl Authors Upload Server (PAUSE).
249             The file records what version of what modules are included in each
250             release of a distribution that is on CPAN.
251              
252             PAUSE::Packages processes 02packages.details.txt and caches a transformed
253             version of the data, with the following characteristics:
254              
255             =over 4
256              
257             =item *
258              
259             Only the highest numbered version of a module is included.
260              
261             =item *
262              
263             All modules in a release are written together, to make it efficient to
264             iterate over the file release by release.
265             02packages is sorted by module name, not by release, which means it can't
266             be efficiently processed by an iterator.
267              
268             =back
269              
270             The interface for this distribution is very much still in flux,
271             as is the documentation.
272              
273             =head1 constructor
274              
275             The constructor (C<new()>) can be passed an argument C<path>,
276             along with a path to a local copy of the I<cached format> used by
277             PAUSE::Packages:
278              
279             $pp = PAUSE::Packages->new(path => 'mypackages.txt');
280              
281             Note: this is not the same format used by 02packages.details.txt,
282             as described above.
283              
284             If you don't specify a path, then the local cache path is generated,
285             and you can use the C<path> attribute to find out what it is:
286              
287             $pp = PAUSE::Packages->new();
288             print "cache path = ", $pp->path, "\n";
289              
290             In a future release this will change: there will be separate attributes
291             for the cache path and the path to your own local copy.
292              
293             =head1 METHODS
294              
295             =head2 release_iterator()
296              
297             See the SYNOPSIS.
298              
299             This supports one optional argument, C<well_formed>,
300             which if true says that the iterator should only return releases
301             where the dist name and author's PAUSE id could be found:
302              
303             my $iterator = PAUSE::Packages->new()->release_iterator(
304             well_formed => 1
305             );
306              
307             This saves you from having to write code like the following:
308              
309             while (my $release = $iterator->next_release) {
310             next unless defined($release->distinfo);
311             next unless defined($release->distinfo->dist);
312             next unless defined($release->distinfo->cpanid);
313             ...
314             }
315              
316             =head2 release($DISTNAME)
317              
318             Takes a dist name and returns an instance of L<PAUSE::Packages::Release>,
319             or C<undef> if a release couldn't be found for the specified distname.
320              
321             =head2 ua( MyUserAgent->new )
322              
323             Allows you to provide your own UserAgent. This is useful if you're working off
324             a local copy of 02packages.details.txt The default UserAgent is HTTP::Tiny,
325             which does not support the file:// schema. So, if you want to work with a
326             local file you can either set up local web server using something like
327             L<App::HTTPThis>, or you can provide a your own UserAgent (like
328             L<LWP::UserAgent> which does support this behaviour.
329              
330             =head2 url
331              
332             The URL to the 02packages.details.txt which you would like to parse. Defaults
333             to cpan.org If you want to use the file:// scheme to fetch your local package,
334             be sure to provide your own UserAgent. See the ua method above.
335              
336             =head1 NOTE
337              
338             The behaviour of this module changed between version 0.01 and 0.02,
339             so you should make sure you're using 0.02 or later:
340              
341             use PAUSE::Packages 0.02;
342              
343             =head1 SEE ALSO
344              
345             There are at least three other modules on CPAN
346             for parsing 02packages.details.txt.
347             There are two main differences between these modules and PAUSE::Packages:
348             (1) you have to download 02packages yourself, and
349             (2) if there are multiple releases of a dist on CPAN, containing different modules (eg due to refactoring), then you'll see the union of all modules, instead of just the modules in the most recent release.
350              
351             =over 4
352              
353             =item *
354              
355             L<Parse::CPAN::Packages>
356              
357             =item *
358              
359             L<Parse::CPAN::Packages::Fast> - a 'largely API compatible rewrite' of
360             the above module, which is claimed to be a lot faster.
361              
362             =item *
363              
364             L<Parse::CPAN::Perms>
365              
366             =item *
367              
368             L<CPAN::Common::Index> - aims to be a common interface to all available backends
369              
370             =item *
371              
372             L<CPAN::PackageDetails> - can be used to read an existing copy of
373             02packages.details.txt, or to create your own.
374              
375             =back
376              
377             =head1 REPOSITORY
378              
379             L<https://github.com/neilb/PAUSE-Packages>
380              
381             =head1 AUTHOR
382              
383             Neil Bowers E<lt>neilb@cpan.orgE<gt>
384              
385             =head1 COPYRIGHT AND LICENSE
386              
387             This software is copyright (c) 2013-2014 by Neil Bowers <neilb@cpan.org>.
388              
389             This is free software; you can redistribute it and/or modify it under
390             the same terms as the Perl 5 programming language system itself.
391              
392             =cut
393