File Coverage

blib/lib/CPAN/Mini.pm
Criterion Covered Total %
statement 47 144 32.6
branch 18 98 18.4
condition 0 17 0.0
subroutine 12 23 52.2
pod n/a
total 77 282 27.3


line stmt bran cond sub pod time code
1 3     3   55 use strict;
  3         38  
  3         51  
2 3     3   50 use warnings;
  3         29  
  3         54  
3              
4             package CPAN::Mini;
5             our $VERSION = '0.552';
6              
7             ## no critic RequireCarping
8              
9             =head1 NAME
10            
11             CPAN::Mini - create a minimal mirror of CPAN
12            
13             =head1 VERSION
14            
15             version 0.552
16            
17             $Id: /my/cs/projects/minicpan/trunk/lib/CPAN/Mini.pm 28751 2006-12-01T16:07:34.495420Z rjbs $
18            
19             =head1 SYNOPSIS
20            
21             (If you're not going to do something weird, you probably want to look at the
22             L<minicpan> command, instead.)
23            
24             use CPAN::Mini;
25            
26             CPAN::Mini->update_mirror(
27             remote => "http://cpan.mirrors.comintern.su",
28             local => "/usr/share/mirrors/cpan",
29             trace => 1
30             );
31            
32             =head1 DESCRIPTION
33            
34             CPAN::Mini provides a simple mechanism to build and update a minimal mirror of
35             the CPAN on your local disk. It contains only those files needed to install
36             the newest version of every distribution. Those files are:
37            
38             =over 4
39            
40             =item * 01mailrc.txt.gz
41            
42             =item * 02packages.details.txt.gz
43            
44             =item * 03modlist.data.gz
45            
46             =item * the last non-developer release of every dist for every author
47            
48             =back
49            
50             =cut
51              
52 3     3   46 use Carp ();
  3         26  
  3         62  
53              
54 3     3   51 use File::Path ();
  3         27  
  3         27  
55 3     3   43 use File::Basename ();
  3         25  
  3         29  
56 3     3   698 use File::Spec ();
  3         26  
  3         29  
57 3     3   42 use File::Find ();
  3         1773  
  3         27  
58              
59 3     3   89 use URI ();
  3         31  
  3         30  
60 3     3   126 use LWP::Simple ();
  3         33  
  3         30  
61              
62 3     3   96 use Compress::Zlib ();
  3         34  
  3         33  
63              
64             =head1 METHODS
65            
66             =head2 update_mirror
67            
68             CPAN::Mini->update_mirror(
69             remote => "http://cpan.mirrors.comintern.su",
70             local => "/usr/share/mirrors/cpan",
71             force => 0,
72             trace => 1
73             );
74            
75             This is the only method that need be called from outside this module. It will
76             update the local mirror with the files from the remote mirror.
77            
78             If called as a class method, C<update_mirror> creates an ephemeral CPAN::Mini
79             object on which other methods are called. That object is used to store mirror
80             location and state.
81            
82             This method returns the number of files updated.
83            
84             The following options are recognized:
85            
86             =over 4
87            
88             =item * C<dirmode>
89            
90             Generally an octal number, this option sets the permissions of created
91             directories. It defaults to 0711.
92            
93             =item * C<exact_mirror>
94            
95             If true, the C<files_allowed> method will allow all extra files to be mirrored.
96            
97             =item * C<force>
98            
99             If true, this option will cause CPAN::Mini to read the entire module list and
100             update anything out of date, even if the module list itself wasn't out of date
101             on this run.
102            
103             =item * C<skip_perl>
104            
105             If true, CPAN::Mini will skip the major language distributions: perl, parrot,
106             and ponie.
107            
108             =item * C<trace>
109            
110             If true, CPAN::Mini will print status messages to STDOUT as it works.
111            
112             =item * C<errors>
113            
114             If true, CPAN::Mini will warn with status messages on errors. (default: true)
115            
116             =item * C<path_filters>
117            
118             This options provides a set of rules for filtering paths. If a distribution
119             matches one of the rules in C<path_filters>, it will not be mirrored. A regex
120             rule is matched if the path matches the regex; a code rule is matched if the
121             code returns 1 when the path is passed to it. For example, the following
122             setting would skip all distributions from RJBS and SUNGO:
123            
124             path_filters => [
125             qr/RJBS/,
126             sub { $_[0] =~ /SUNGO/ }
127             ]
128            
129             =item * C<module_filters>
130            
131             This option provides a set of rules for filtering modules. It behaves like
132             path_filters, but acts only on module names. (Since most modules are in
133             distributions with more than one module, this setting will probably be less
134             useful than C<path_filters>.) For example, this setting will skip any
135             distribution containing only modules with the word "Acme" in them:
136            
137             module_filters => [ qr/Acme/i ]
138            
139             =item * C<also_mirror>
140            
141             This option should be an arrayref of extra files in the remote CPAN to mirror
142             locally.
143            
144             =item * C<skip_cleanup>
145            
146             If this option is true, CPAN::Mini will not try delete unmirrored files when it
147             has finished mirroring
148            
149             =back
150            
151             =cut
152              
153             sub update_mirror {
154 0     0   0 my $self = shift;
155 0 0       0 $self = $self->new(@_) unless ref $self;
156              
157             # mirrored tracks the already done, keyed by filename
158             # 1 = local-checked, 2 = remote-mirrored
159 0         0 $self->mirror_indices;
160              
161 0 0 0     0 return unless $self->{force} or $self->{changes_made};
162              
163             # now walk the packages list
164 0         0 my $details = File::Spec->catfile(
165                 $self->{local},
166                 qw(modules 02packages.details.txt.gz)
167               );
168              
169 0 0       0 my $gz = Compress::Zlib::gzopen($details, "rb")
170                 or die "Cannot open details: $Compress::Zlib::gzerrno";
171              
172 0         0 my $inheader = 1;
173 0         0 while ($gz->gzreadline($_) > 0) {
174 0 0       0 if ($inheader) {
175 0 0       0 $inheader = 0 unless /\S/;
176 0         0 next;
177             }
178              
179 0         0 my ($module, $version, $path) = split;
180 0 0       0 next if $self->_filter_module({
181             module  => $module,
182             version => $version,
183             path    => $path,
184             });
185              
186 0         0 $self->mirror_file("authors/id/$path", 1);
187             }
188              
189             # eliminate files we don't need
190 0 0       0 $self->clean_unmirrored unless $self->{skip_cleanup};
191 0         0 return $self->{changes_made};
192             }
193              
194             =head2 new
195            
196             my $minicpan = CPAN::Mini->new;
197            
198             This method constructs a new CPAN::Mini object. Its parameters are described
199             above, under C<update_mirror>.
200            
201             =cut
202              
203             sub new {
204 0     0   0 my $class = shift;
205 0         0 my %defaults = (
206                 changes_made => 0,
207                 dirmode => 0711, ## no critic Zero
208                 errors => 1,
209                 mirrored => {}
210               );
211              
212 0         0 my $self = bless { %defaults, @_ } => $class;
213              
214 0 0       0 Carp::croak "no local mirror supplied" unless $self->{local};
215              
216 0 0       0   substr($self->{local}, 0, 1, $class->__homedir)
217                 if substr($self->{local}, 0, 1) eq q{~};
218              
219 0 0 0     0   Carp::croak "local mirror path exists but is not a directory"
220                 if (-e $self->{local}) and not (-d $self->{local});
221              
222 0 0       0   File::Path::mkpath($self->{local}, $self->{trace}, $self->{dirmode})
223                 unless -e $self->{local};
224              
225 0 0       0   Carp::croak "no write permission to local mirror" unless -w $self->{local};
226              
227 0 0       0 Carp::croak "no remote mirror supplied" unless $self->{remote};
228 0 0       0   Carp::croak "unable to contact the remote mirror"
229                 unless LWP::Simple::head($self->{remote});
230              
231 0         0 return $self;
232             }
233              
234             =head2 mirror_indices
235            
236             $minicpan->mirror_indices;
237            
238             This method updates the index files from the CPAN.
239            
240             =cut
241              
242             sub mirror_indices {
243 0     0   0 my $self = shift;
244              
245 0         0   my @fixed_mirrors = qw(
246             authors/01mailrc.txt.gz
247             modules/02packages.details.txt.gz
248             modules/03modlist.data.gz
249             );
250              
251             # XXX: Should the 0 be a 1, below? -- rjbs, 2006-08-08
252 0         0 $self->mirror_file($_, undef, 0) for @fixed_mirrors, @{$self->{also_mirror}};
  0         0  
  0         0  
253             }
254              
255             =head2 mirror_file
256            
257             $minicpan->mirror_file($path, $skip_if_present)
258            
259             This method will mirror the given file from the remote to the local mirror,
260             overwriting any existing file unless C<$skip_if_present> is true.
261            
262             =cut
263              
264             sub mirror_file {
265 0     0   0 my $self = shift;
266 0         0 my $path = shift; # partial URL
267 0         0 my $skip_if_present = shift; # true/false
268 0         0   my $update_times = shift; # true/false
269              
270             # full URL
271 0         0 my $remote_uri = URI->new_abs($path, $self->{remote})->as_string;
272              
273             # native absolute file
274 0         0 my $local_file = File::Spec->catfile($self->{local}, split m{/}, $path);
275              
276 0         0 my $checksum_might_be_up_to_date = 1;
277              
278 0 0 0     0 if ($skip_if_present and -f $local_file) {
    0 0        
279             ## upgrade to checked if not already
280 0 0       0 $self->{mirrored}{$local_file} = 1 unless $self->{mirrored}{$local_file};
281             } elsif (($self->{mirrored}{$local_file} || 0) < 2) {
282             ## upgrade to full mirror
283 0         0 $self->{mirrored}{$local_file} = 2;
284              
285 0         0 File::Path::mkpath(
286                   File::Basename::dirname($local_file),
287                   $self->{trace},
288                   $self->{dirmode}
289                 );
290              
291 0         0 $self->trace($path);
292 0         0 my $status = LWP::Simple::mirror($remote_uri, $local_file);
293              
294 0 0       0 if ($status == LWP::Simple::RC_OK) {
    0          
295 0 0       0       utime undef, undef, $local_file if $update_times;
296 0         0 $checksum_might_be_up_to_date = 0;
297 0         0 $self->trace(" ... updated\n");
298 0         0 $self->{changes_made}++;
299             } elsif ($status != LWP::Simple::RC_NOT_MODIFIED) {
300 0 0       0 warn( ($self->{trace} ? "\n" : q{})
    0          
301                     . "$remote_uri: $status\n") if $self->{errors};
302 0         0 return;
303             } else {
304 0         0 $self->trace(" ... up to date\n");
305             }
306             }
307              
308 0 0       0 if ($path =~ m{^authors/id}) { # maybe fetch CHECKSUMS
309 0         0 my $checksum_path =
310             URI->new_abs("CHECKSUMS", $remote_uri)->rel($self->{remote});
311 0 0       0 if ($path ne $checksum_path) {
312 0         0 $self->mirror_file($checksum_path, $checksum_might_be_up_to_date);
313             }
314             }
315             }
316              
317             =begin devel
318            
319             =head2 _filter_module
320            
321             next if
322             $self->_filter_module({ module => $foo, version => $foo, path => $foo });
323            
324             This internal-only method encapsulates the logic where we figure out if a
325             module is to be mirrored or not. Better stated, this method holds the filter
326             chain logic. C<update_mirror()> takes an optional set of filter parameters. As
327             C<update_mirror()> encounters a distribution, it calls this method to figure
328             out whether or not it should be downloaded. The user provided filters are taken
329             into account. Returns 1 if the distribution is filtered (to be skipped).
330             Returns 0 if the distribution is to not filtered (not to be skipped).
331            
332             =end devel
333            
334             =cut
335              
336             sub __do_filter {
337 45     45   502 my ($self, $filter, $file) = @_;
338 45 100       1504 return unless $filter;
339 39 100       429 if (ref($filter) eq 'ARRAY') {
340 11         106 for (@$filter) {
341 25 100       239 return 1 if $self->__do_filter($_, $file);
342             }
343             }
344 32 100       338 if (ref($filter) eq 'CODE') {
345 6         2612 return $filter->($file);
346             } else {
347 26         571 return $file =~ $filter;
348             }
349             }
350              
351             sub _filter_module {
352 19     19   1774 my $self = shift;
353 19         2193 my $args = shift;
354              
355 19 100       365 if ($self->{skip_perl}) {
356 6 100       194 return 1 if $args->{path} =~ m{/(?:emb|syb|bio)*perl-\d}i;
357 3 100       50 return 1 if $args->{path} =~ m{/(?:parrot|ponie)-\d}i;
358 1 50       14 return 1 if $args->{path} =~ m{/\bperl5\.004}i;
359             }
360              
361 14 100       1636 return 1 if $self->__do_filter($self->{path_filters}, $args->{path});
362 6 50       79 return 1 if $self->__do_filter($self->{module_filters}, $args->{module});
363 6         91 return 0;
364             }
365              
366             =head2 file_allowed
367            
368             next unless $minicpan->file_allowed($filename);
369            
370             This method returns true if the given file is allowed to exist in the local
371             mirror, even if it isn't one of the required mirror files.
372            
373             By default, only dot-files are allowed. If the C<exact_mirror> option is true,
374             all files are allowed.
375            
376             =cut
377              
378