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             sub file_allowed {
379 0     0     my ($self, $file) = @_;
380 0 0         return if $self->{exact_mirror};
381 0 0         return (substr(File::Basename::basename($file),0,1) eq q{.}) ? 1 : 0;
382             }
383              
384             =head2 clean_unmirrored
385            
386             $minicpan->clean_unmirrored;
387            
388             This method looks through the local mirror's files. If it finds a file that
389             neither belongs in the mirror nor is allowed (see the C<file_allowed> method),
390             C<clean_file> is called on the file.
391            
392             =cut
393              
394             sub clean_unmirrored {
395 0     0     my $self = shift;
396              
397             File::Find::find sub {
398 0     0     my $file = File::Spec->canonpath($File::Find::name); ## no critic Package
399 0 0 0           return unless (-f $file and not $self->{mirrored}{$file});
400 0 0             return if $self->file_allowed($file);
401 0               $self->trace("cleaning $file ...");
402 0 0         if ($self->clean_file($file)) {
403 0                 $self->trace("done\n");
404                 } else {
405 0                 $self->trace("couldn't be cleaned\n");
406                 }
407 0           }, $self->{local};
408             }
409              
410             =head2 clean_file
411            
412             $minicpan->clean_file($filename);
413            
414             This method, called by C<clean_unmirrored>, deletes the named file. It returns
415             true if the file is successfully unlinked. Otherwise, it returns false.
416            
417             =cut
418              
419             sub clean_file {
420 0     0     my ($self, $file) = @_;
421              
422 0 0         unless (unlink $file) {
423 0 0             warn "$file ... cannot be removed: $!\n" if $self->{errors};
424 0               return;
425               }
426 0             return 1;
427             }
428              
429             =head2 trace
430            
431             $minicpan->trace($message);
432            
433             If the object is mirroring verbosely, this method will print messages sent to
434             it.
435            
436             =cut
437              
438             sub trace {
439 0     0     my ($self, $message) = @_;
440 0 0         print "$message" if $self->{trace};
441             }
442              
443             =head2 read_config
444            
445             my %config = CPAN::Mini->read_config;
446            
447             This routine returns a set of arguments that can be passed to CPAN::Mini's
448             C<new> or C<update_mirror> methods. It will look for a file called
449             F<.minicpanrc> in the user's home directory as determined by
450             L<File::HomeDir|File::HomeDir>.
451            
452             =cut
453              
454             sub __homedir {
455 0     0       my ($class) = @_;
456              
457 0   0         my $homedir = File::HomeDir->my_home || $ENV{HOME};
458              
459 0 0           Carp::croak "couldn't determine your home directory! set HOME env variable"
460                 unless defined $homedir;
461               
462 0             return $homedir;
463             }
464              
465             sub read_config {
466 0     0       my ($class) = @_;
467              
468 0             my $filename = File::Spec->catfile($class->__homedir, '.minicpanrc');
469              
470 0 0           return unless -e $filename;
471              
472 0 0           open my $config_file, '<', $filename
473                 or die "couldn't open config file $filename: $!";
474               
475 0             my %config;
476 0             while (<$config_file>) {
477 0               chomp;
478 0 0             next if /\A\s*\Z/sm;
479 0 0             if (/\A(\w+):\s*(.+)\Z/sm) { $config{$1} = $2; }
  0            
480               }
481 0             for (qw(also_mirror)) {
482 0 0             $config{$_} = [ grep { length } split /\s+/, $config{$_}] if $config{$_};
  0            
483               }
484 0             for (qw(module_filters path_filters)) {
485 0 0             $config{$_} = [ map { qr/$_/ } split /\s+/, $config{$_} ] if $config{$_};
  0            
486               }
487 0             return %config;
488             }
489              
490             =head2
491            
492             =head1 SEE ALSO
493            
494             Randal Schwartz's original article on minicpan, here:
495            
496             http://www.stonehenge.com/merlyn/LinuxMag/col42.html
497            
498             L<CPANPLUS::Backend>, which provides the C<local_mirror> method, which performs
499             the same task as this module.
500            
501             =head1 THANKS
502            
503             Thanks to David Dyck for letting me know about my stupid documentation errors.
504            
505             Thanks to Roy Fulbright for finding an obnoxious bug on Win32.
506            
507             Thanks to Shawn Sorichetti for fixing a stupid octal-number-as-string bug.
508            
509             Thanks to sungo for implementing the filters, so I can finally stop mirroring
510             bioperl, and Robert Rothenberg for suggesting adding coderef rules.
511            
512             Thanks to Adam Kennedy for noticing and complaining about a lot of stupid
513             little design decisions.
514            
515             Thanks to Michael Schwern and Jason Kohles, for pointing out missing
516             documentation.
517            
518             =head1 AUTHORS
519            
520             Randal Schwartz <F<merlyn@stonehenge.com>> wrote the original F<minicpan>
521             script.
522            
523             Ricardo SIGNES <F<rjbs@cpan.org>> turned Randal's script into a module and CPAN
524             distribution, and has maintained it since its release as such.
525            
526             This code was copyrighted in 2004, and is released under the same terms as Perl
527             itself.
528            
529             =cut
530              
531             1;
532