File Coverage

lib/CPANPLUS/Backend.pm
Criterion Covered Total %
statement 273 298 91.6
branch 89 134 66.4
condition 28 48 58.3
subroutine 30 35 85.7
pod 18 18 100.0
total 438 533 82.1


line stmt bran cond sub pod time code
1             package CPANPLUS::Backend;
2              
3 20     20   135 use strict;
  20         40  
  20         707  
4              
5              
6 20     20   126 use CPANPLUS::Error;
  20         63  
  20         1377  
7 20     20   188 use CPANPLUS::Configure;
  20         49  
  20         1577  
8 20     20   7697 use CPANPLUS::Internals;
  20         69  
  20         973  
9 20     20   166 use CPANPLUS::Internals::Constants;
  20         42  
  20         7315  
10 20     20   178 use CPANPLUS::Module;
  20         59  
  20         632  
11 20     20   130 use CPANPLUS::Module::Author;
  20         41  
  20         604  
12 20     20   8629 use CPANPLUS::Backend::RV;
  20         53  
  20         560  
13              
14 20     20   125 use FileHandle;
  20         43  
  20         150  
15 20     20   5801 use File::Spec ();
  20         41  
  20         328  
16 20     20   98 use File::Spec::Unix ();
  20         54  
  20         275  
17 20     20   115 use File::Basename ();
  20         40  
  20         524  
18 20     20   110 use Params::Check qw[check];
  20         34  
  20         1018  
19 20     20   137 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  20         50  
  20         142  
20              
21             $Params::Check::VERBOSE = 1;
22              
23 20     20   5379 use vars qw[@ISA $VERSION];
  20         43  
  20         15225  
24              
25             @ISA = qw[CPANPLUS::Internals];
26             $VERSION = "0.9914";
27              
28             ### mark that we're running under CPANPLUS to spawned processes
29             $ENV{'PERL5_CPANPLUS_IS_RUNNING'} = $$;
30              
31             ### XXX version.pm MAY format this version, if it's in use... :(
32             ### so for consistency, just call ->VERSION ourselves as well.
33             $ENV{'PERL5_CPANPLUS_IS_VERSION'} = __PACKAGE__->VERSION;
34              
35             =pod
36              
37             =head1 NAME
38              
39             CPANPLUS::Backend - programmer's interface to CPANPLUS
40              
41             =head1 SYNOPSIS
42              
43             my $cb = CPANPLUS::Backend->new;
44             my $conf = $cb->configure_object;
45              
46             my $author = $cb->author_tree('KANE');
47             my $mod = $cb->module_tree('Some::Module');
48             my $mod = $cb->parse_module( module => 'Some::Module' );
49              
50             my @objs = $cb->search( type => TYPE,
51             allow => [...] );
52              
53             $cb->flush('all');
54             $cb->reload_indices;
55             $cb->local_mirror;
56              
57              
58             =head1 DESCRIPTION
59              
60             This module provides the programmer's interface to the C
61             libraries.
62              
63             =head1 ENVIRONMENT
64              
65             When C is loaded, which is necessary for just
66             about every operation, the environment variable
67             C is set to the current process id.
68              
69             Additionally, the environment variable C
70             will be set to the version of C.
71              
72             This information might be useful somehow to spawned processes.
73              
74             =head1 METHODS
75              
76             =head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] )
77              
78             This method returns a new C object.
79             This also initialises the config corresponding to this object.
80             You have two choices in this:
81              
82             =over 4
83              
84             =item Provide a valid C object
85              
86             This will be used verbatim.
87              
88             =item No arguments
89              
90             Your default config will be loaded and used.
91              
92             =back
93              
94             New will return a C object on success and die on
95             failure.
96              
97             =cut
98              
99             sub new {
100 14     14 1 3160 my $class = shift;
101 14         40 my $conf;
102              
103 14 50 33     141 if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) {
104 14         44 $conf = shift;
105             } else {
106 0 0       0 $conf = CPANPLUS::Configure->new() or return;
107             }
108              
109 14         189 my $self = $class->SUPER::_init( _conf => $conf );
110              
111 14         190 return $self;
112             }
113              
114             =pod
115              
116             =head2 $href = $cb->module_tree( [@modules_names_list] )
117              
118             Returns a reference to the CPANPLUS module tree.
119              
120             If you give it any arguments, they will be treated as module names
121             and C will try to look up these module names and
122             return the corresponding module objects instead.
123              
124             See L for the operations you can perform on a
125             module object.
126              
127             =cut
128              
129             sub module_tree {
130 3392     3392 1 43829 my $self = shift;
131 3392         11087 my $modtree = $self->_module_tree;
132              
133 3392 100       7727 if( @_ ) {
134 2986         4780 my @rv;
135 2986         6276 for my $name ( grep { defined } @_) {
  2987         10718  
136              
137             ### From John Malmberg: This is failing on VMS
138             ### because ODS-2 does not retain the case of
139             ### filenames that are created.
140             ### The problem is the filename is being converted
141             ### to a module name and then looked up in the
142             ### %$modtree hash.
143             ###
144             ### As a fix, we do a search on VMS instead --
145             ### more cpu cycles, but it gets around the case
146             ### problem --kane
147 2986         5131 my ($modobj) = do {
148             ON_VMS
149             ? $self->search(
150             type => 'module',
151             allow => [qr/^$name$/i],
152             )
153 2986         6914 : $modtree->{$name}
154             };
155              
156 2986   100     13022 push @rv, $modobj || '';
157             }
158 2986 100       11910 return @rv == 1 ? $rv[0] : @rv;
159             } else {
160 406         3535 return $modtree;
161             }
162             }
163              
164             =pod
165              
166             =head2 $href = $cb->author_tree( [@author_names_list] )
167              
168             Returns a reference to the CPANPLUS author tree.
169              
170             If you give it any arguments, they will be treated as author names
171             and C will try to look up these author names and
172             return the corresponding author objects instead.
173              
174             See L for the operations you can perform on
175             an author object.
176              
177             =cut
178              
179             sub author_tree {
180 164     164 1 463 my $self = shift;
181 164         1219 my $authtree = $self->_author_tree;
182              
183 164 100       553 if( @_ ) {
184 3         7 my @rv;
185 3         16 for my $name (@_) {
186 4   100     23 push @rv, $authtree->{$name} || '';
187             }
188 3 100       24 return @rv == 1 ? $rv[0] : @rv;
189             } else {
190 161         1298 return $authtree;
191             }
192             }
193              
194             =pod
195              
196             =head2 $conf = $cb->configure_object;
197              
198             Returns a copy of the C object.
199              
200             See L for operations you can perform on a
201             configure object.
202              
203             =cut
204              
205 1405     1405 1 17334 sub configure_object { return shift->_conf() };
206              
207             =head2 $su = $cb->selfupdate_object;
208              
209             Returns a copy of the C object.
210              
211             See the L manpage for the operations
212             you can perform on the selfupdate object.
213              
214             =cut
215              
216 15     15 1 13266 sub selfupdate_object { return shift->_selfupdate() };
217              
218             =pod
219              
220             =head2 @mods = $cb->search( type => TYPE, allow => AREF, [data => AREF, verbose => BOOL] )
221              
222             C enables you to search for either module or author objects,
223             based on their data. The C you can specify is any of the
224             accessors specified in C or
225             C. C will determine by the C you
226             specified whether to search by author object or module object.
227              
228             You have to specify an array reference of regular expressions or
229             strings to match against. The rules used for this array ref are the
230             same as in C, so read that manpage for details.
231              
232             The search is an C search, meaning that if C of the criteria
233             match, the search is considered to be successful.
234              
235             You can specify the result of a previous search as C to limit
236             the new search to these module or author objects, rather than the
237             entire module or author tree. This is how you do C searches.
238              
239             Returns a list of module or author objects on success and false
240             on failure.
241              
242             See L for the operations you can perform on a
243             module object.
244             See L for the operations you can perform on
245             an author object.
246              
247             =cut
248              
249             sub search {
250 80     80 1 1952 my $self = shift;
251 80         227 my $conf = $self->configure_object;
252 80         582 my %hash = @_;
253              
254 80         197 my ($type);
255 80 100       159 my $args = do {
256 80         232 local $Params::Check::NO_DUPLICATES = 0;
257 80         208 local $Params::Check::ALLOW_UNKNOWN = 1;
258              
259 80         611 my $tmpl = {
260             type => { required => 1, allow => [CPANPLUS::Module->accessors(),
261             CPANPLUS::Module::Author->accessors()], store => \$type },
262             allow => { required => 1, default => [ ], strict_type => 1 },
263             };
264              
265 80         427 check( $tmpl, \%hash )
266             } or return;
267              
268             ### figure out whether it was an author or a module search
269             ### when ambiguous, it'll be an author search.
270 79         14226 my $aref;
271 79 100       303 if( grep { $type eq $_ } CPANPLUS::Module::Author->accessors() ) {
  316         735  
272 3         31 $aref = $self->_search_author_tree( %$args );
273             } else {
274 76         865 $aref = $self->_search_module_tree( %$args );
275             }
276              
277 79 50       571 return @$aref if $aref;
278 0         0 return;
279             }
280              
281             =pod
282              
283             =head2 $backend_rv = $cb->fetch( modules => \@mods )
284              
285             Fetches a list of modules. C<@mods> can be a list of distribution
286             names, module names or module objects--basically anything that
287             L can understand.
288              
289             See the equivalent method in C for details on
290             other options you can pass.
291              
292             Since this is a multi-module method call, the return value is
293             implemented as a C object. Please consult
294             that module's documentation on how to interpret the return value.
295              
296             =head2 $backend_rv = $cb->extract( modules => \@mods )
297              
298             Extracts a list of modules. C<@mods> can be a list of distribution
299             names, module names or module objects--basically anything that
300             L can understand.
301              
302             See the equivalent method in C for details on
303             other options you can pass.
304              
305             Since this is a multi-module method call, the return value is
306             implemented as a C object. Please consult
307             that module's documentation on how to interpret the return value.
308              
309             =head2 $backend_rv = $cb->install( modules => \@mods )
310              
311             Installs a list of modules. C<@mods> can be a list of distribution
312             names, module names or module objects--basically anything that
313             L can understand.
314              
315             See the equivalent method in C for details on
316             other options you can pass.
317              
318             Since this is a multi-module method call, the return value is
319             implemented as a C object. Please consult
320             that module's documentation on how to interpret the return value.
321              
322             =head2 $backend_rv = $cb->readme( modules => \@mods )
323              
324             Fetches the readme for a list of modules. C<@mods> can be a list of
325             distribution names, module names or module objects--basically
326             anything that L can understand.
327              
328             See the equivalent method in C for details on
329             other options you can pass.
330              
331             Since this is a multi-module method call, the return value is
332             implemented as a C object. Please consult
333             that module's documentation on how to interpret the return value.
334              
335             =head2 $backend_rv = $cb->files( modules => \@mods )
336              
337             Returns a list of files used by these modules if they are installed.
338             C<@mods> can be a list of distribution names, module names or module
339             objects--basically anything that L can understand.
340              
341             See the equivalent method in C for details on
342             other options you can pass.
343              
344             Since this is a multi-module method call, the return value is
345             implemented as a C object. Please consult
346             that module's documentation on how to interpret the return value.
347              
348             =head2 $backend_rv = $cb->distributions( modules => \@mods )
349              
350             Returns a list of module objects representing all releases for this
351             module on success.
352             C<@mods> can be a list of distribution names, module names or module
353             objects, basically anything that L can understand.
354              
355             See the equivalent method in C for details on
356             other options you can pass.
357              
358             Since this is a multi-module method call, the return value is
359             implemented as a C object. Please consult
360             that module's documentation on how to interpret the return value.
361              
362             =cut
363              
364             ### XXX add directory_tree, packlist etc? or maybe remove files? ###
365             for my $func (qw[fetch extract install readme files distributions]) {
366 20     20   177 no strict 'refs';
  20         43  
  20         65862  
367              
368             *$func = sub {
369 1     1   696 my $self = shift;
370 1         6 my $conf = $self->configure_object;
371 1         5 my %hash = @_;
372              
373 1         3 my ($mods);
374 1 50       2 my $args = do {
375 1         2 local $Params::Check::NO_DUPLICATES = 1;
376 1         4 local $Params::Check::ALLOW_UNKNOWN = 1;
377              
378 1         6 my $tmpl = {
379             modules => { default => [], strict_type => 1,
380             required => 1, store => \$mods },
381             };
382              
383 1         5 check( $tmpl, \%hash );
384             } or return;
385              
386             ### make them all into module objects ###
387 1   50     83 my %mods = map { $_ => $self->parse_module(module => $_) || '' } @$mods;
  1         4  
388              
389 1         3 my $flag; my $href;
390 1         7 while( my($name,$obj) = each %mods ) {
391 1 50       4 $href->{$name} = IS_MODOBJ->( mod => $obj )
392             ? $obj->$func( %$args )
393             : undef;
394              
395 1 50       351 $flag++ unless $href->{$name};
396             }
397              
398 1 50       71 return CPANPLUS::Backend::RV->new(
399             function => $func,
400             ok => ( !$flag ? 1 : 0 ),
401             rv => $href,
402             args => \%hash,
403             );
404             }
405             }
406              
407             =pod
408              
409             =head2 $mod_obj = $cb->parse_module( module => $modname|$distname|$modobj|URI|PATH )
410              
411             C tries to find a C object that
412             matches your query. Here's a list of examples you could give to
413             C;
414              
415             =over 4
416              
417             =item Text::Bastardize
418              
419             =item Text-Bastardize
420              
421             =item Text/Bastardize.pm
422              
423             =item Text-Bastardize-1.06
424              
425             =item AYRNIEU/Text-Bastardize
426              
427             =item AYRNIEU/Text-Bastardize-1.06
428              
429             =item AYRNIEU/Text-Bastardize-1.06.tar.gz
430              
431             =item http://example.com/Text-Bastardize-1.06.tar.gz
432              
433             =item file:///tmp/Text-Bastardize-1.06.tar.gz
434              
435             =item /tmp/Text-Bastardize-1.06
436              
437             =item ./Text-Bastardize-1.06
438              
439             =item .
440              
441             =back
442              
443             These items would all come up with a C object for
444             C. The ones marked explicitly as being version 1.06
445             would give back a C object of that version.
446             Even if the version on CPAN is currently higher.
447              
448             The last three are examples of PATH resolution. In the first, we supply
449             an absolute path to the unwrapped distribution. In the second the
450             distribution is relative to the current working directory.
451             In the third, we will use the current working directory.
452              
453             If C is unable to actually find the module you are looking
454             for in its module tree, but you supplied it with an author, module
455             and version part in a distribution name or URI, it will create a fake
456             C object for you, that you can use just like the
457             real thing.
458              
459             See L for the operations you can perform on a
460             module object.
461              
462             If even this fancy guessing doesn't enable C to create
463             a fake module object for you to use, it will warn about an error and
464             return false.
465              
466             =cut
467              
468             sub parse_module {
469 49     49 1 31761 my $self = shift;
470 49         193 my $conf = $self->configure_object;
471 49         177 my %hash = @_;
472              
473 49         91 my $mod;
474 49         223 my $tmpl = {
475             module => { required => 1, store => \$mod },
476             };
477              
478 49 50       209 my $args = check( $tmpl, \%hash ) or return;
479              
480 49 100       3809 return $mod if IS_MODOBJ->( module => $mod );
481              
482             ### ok, so it's not a module object, but a ref nonetheless?
483             ### what are you smoking?
484 48 100       133 if( ref $mod ) {
485 1         4 error(loc("Can not parse module string from reference '%1'", $mod ));
486 1         14 return;
487             }
488              
489             ### check only for allowed characters in a module name
490 47 100       328 unless( $mod =~ /[^\w:]/ ) {
491              
492             ### perhaps we can find it in the module tree?
493 3         11 my $maybe = $self->module_tree($mod);
494 3 100       9 return $maybe if IS_MODOBJ->( module => $maybe );
495             }
496              
497             ### Special case arbitrary file paths such as '.' etc.
498 45 100 66     2222 if ( $mod and -d File::Spec->rel2abs($mod) ) {
499 1         25 my $dir = File::Spec->rel2abs($mod);
500 1         14 my $parent = File::Spec->rel2abs( File::Spec->catdir( $dir, '..' ) );
501              
502             ### fix paths on VMS
503 1         3 if (ON_VMS) {
504             $dir = VMS::Filespec::unixify($dir);
505             $parent = VMS::Filespec::unixify($parent);
506             }
507              
508 1         130 my $dist = $mod = File::Basename::basename($dir);
509 1 50       7 $dist .= '-0' unless $dist =~ /\-[0-9._]+$/;
510 1 50       12 $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
511              
512 1         7 my $modobj = CPANPLUS::Module::Fake->new(
513             module => $mod,
514             version => 0,
515             package => $dist,
516             path => $parent,
517             author => CPANPLUS::Module::Author::Fake->new
518             );
519              
520             ### better guess for the version
521 1 50       5 $modobj->version( $modobj->package_version )
522             if defined $modobj->package_version;
523              
524             ### better guess at module name, if possible
525 1 50       5 if ( my $pkgname = $modobj->package_name ) {
526 1         4 $pkgname =~ s/-/::/g;
527              
528             ### no sense replacing it unless we changed something
529 1 50 33     4 $modobj->module( $pkgname )
530             if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
531             }
532              
533 1         6 $modobj->status->fetch( $parent );
534 1         120 $modobj->status->extract( $dir );
535 1         123 $modobj->get_installer_type;
536 1         101 return $modobj;
537             }
538              
539             ### ok, so it looks like a distribution then?
540 44         361 my @parts = split '/', $mod;
541 44         112 my $dist = pop @parts;
542              
543             ### ah, it's a URL
544 44 100       275 if( $mod =~ m|\w+://.+| ) {
545 15         163 my $modobj = CPANPLUS::Module::Fake->new(
546             module => $dist,
547             version => 0,
548             package => $dist,
549             path => File::Spec::Unix->catdir(
550             $conf->_get_mirror('base'),
551             UNKNOWN_DL_LOCATION ),
552             author => CPANPLUS::Module::Author::Fake->new
553             );
554              
555             ### set the fetch_from accessor so we know to by pass the
556             ### usual mirrors
557 15         84 $modobj->status->_fetch_from( $mod );
558              
559             ### better guess for the version
560 15 100       1536 $modobj->version( $modobj->package_version )
561             if defined $modobj->package_version;
562              
563             ### better guess at module name, if possible
564 15 100       57 if ( my $pkgname = $modobj->package_name ) {
565 13         41 $pkgname =~ s/-/::/g;
566              
567             ### no sense replacing it unless we changed something
568 13 50 66     51 $modobj->module( $pkgname )
569             if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
570             }
571              
572 15         113 return $modobj;
573             }
574              
575             # Stolen from cpanminus to support 'Module/Install.pm'
576             # type input
577 29 100       120 if ( ( my $tmpmod = $mod ) =~ s/\.pm$//i ) {
578 1         39 my ($volume, $dirs, $file) = File::Spec->splitpath( $tmpmod );
579 1         13 $tmpmod = join '::', grep { $_ } File::Spec->splitdir( $dirs ), $file;
  3         10  
580             ### perhaps we can find it in the module tree?
581 1         5 my $maybe = $self->module_tree( $tmpmod );
582 1 50       4 return $maybe if IS_MODOBJ->( module => $maybe );
583             }
584              
585             ### perhaps we can find it's a third party module?
586 28         40 { my $modobj = CPANPLUS::Module::Fake->new(
  28         233  
587             module => $mod,
588             version => 0,
589             package => $dist,
590             path => File::Spec::Unix->catdir(
591             $conf->_get_mirror('base'),
592             UNKNOWN_DL_LOCATION ),
593             author => CPANPLUS::Module::Author::Fake->new
594             );
595 28 50       115 if( $modobj->is_third_party ) {
596 0         0 my $info = $modobj->third_party_information;
597              
598 0         0 $modobj->author->author( $info->{author} );
599 0         0 $modobj->author->email( $info->{author_url} );
600 0         0 $modobj->description( $info->{url} );
601              
602 0         0 return $modobj;
603             }
604             }
605              
606 28 50       5136 unless( $dist ) {
607 0         0 error( loc("%1 is not a proper distribution name!", $mod) );
608 0         0 return;
609             }
610              
611             ### there's wonky uris out there, like this:
612             ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091
613             ### compensate for that
614 28         58 my $author;
615             ### you probably have an A/AB/ABC/....../Dist.tgz type uri
616 28 100 100     213 if( (defined $parts[0] and length $parts[0] == 1) and
      33        
      66        
      33        
      33        
617             (defined $parts[1] and length $parts[1] == 2) and
618             $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i
619             ) {
620 3         10 splice @parts, 0, 2; # remove the first 2 entries from the list
621 3         8 $author = shift @parts; # this is the actual author name then
622              
623             ### we''ll assume a ABC/..../Dist.tgz
624             } else {
625 25   100     75 $author = shift @parts || '';
626             }
627              
628             {
629 28         41 my $guess = $dist;
  28         45  
630 28 50       128 $guess =~ s!-!::!g if $guess;
631 28         83 my $maybe = $self->module_tree( $guess );
632 28 100       81 if ( IS_MODOBJ->( module => $maybe ) ) {
633 3         9 $dist = $maybe->package;
634             }
635             }
636              
637 28         83 my($pkg, $version, $ext, $full) =
638             $self->_split_package_string( package => $dist );
639              
640             ### translate a distribution into a module name ###
641 28         62 my $guess = $pkg;
642 28 100       110 $guess =~ s/-/::/g if $guess;
643              
644 28         81 my $maybe = $self->module_tree( $guess );
645 28 100 66     530 if( IS_MODOBJ->( module => $maybe ) ) {
    100          
646              
647             ### maybe you asked for a package instead
648 10 50       28 if ( $maybe->package eq $mod ) {
    50          
    0          
649 0         0 return $maybe;
650              
651             ### perhaps an outdated version instead?
652             } elsif ( $version ) {
653 10         21 my $auth_obj; my $path;
654              
655             ### did you give us an author part? ###
656 10 100       18 if( $author ) {
657 6         16 $auth_obj = CPANPLUS::Module::Author::Fake->new(
658             _id => $maybe->_id,
659             cpanid => uc $author,
660             author => uc $author,
661             );
662 6         39 $path = File::Spec::Unix->catdir(
663             $conf->_get_mirror('base'),
664             substr(uc $author, 0, 1),
665             substr(uc $author, 0, 2),
666             uc $author,
667             @parts, #possible sub dirs
668             );
669             } else {
670 4         196 $auth_obj = $maybe->author;
671 4         14 $path = $maybe->path;
672             }
673              
674 10 100       39 if( $maybe->package_name eq $pkg ) {
675              
676             my $modobj = CPANPLUS::Module::Fake->new(
677             module => $maybe->module,
678             version => $version,
679             ### no extension? use the extension the original package
680             ### had instead
681 4 100       17 package => do { $ext
  4         17  
682             ? $full
683             : $full .'.'. $maybe->package_extension
684             },
685             path => $path,
686             author => $auth_obj,
687             _id => $maybe->_id
688             );
689 4         25 return $modobj;
690              
691             ### you asked for a specific version?
692             ### assume our $maybe is the one you wanted,
693             ### and fix up the version..
694             } else {
695              
696 6         31 my $modobj = $maybe->clone;
697 6         21 $modobj->version( $version );
698 6         47 $modobj->package(
699             $maybe->package_name .'-'.
700             $version .'.'.
701             $maybe->package_extension
702             );
703              
704             ### you wanted a specific author, but it's not the one
705             ### from the module tree? we'll fix it up
706 6 100 100     34 if( $author and $author ne $modobj->author->cpanid ) {
707 1         4 $modobj->author( $auth_obj );
708 1         4 $modobj->path( $path );
709             }
710              
711 6         39 return $modobj;
712             }
713              
714             ### you didn't care about a version, so just return the object then
715             } elsif ( !$version ) {
716 0         0 return $maybe;
717             }
718              
719             ### ok, so we can't find it, and it's not an outdated dist either
720             ### perhaps we can fake one based on the author name and so on
721             } elsif ( $author and $version ) {
722              
723             ### be extra friendly and pad the .tar.gz suffix where needed
724             ### it's just a guess of course, but most dists are .tar.gz
725 17 100       94 $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
726              
727             ### XXX duplication from above for generating author obj + path...
728 17         70 my $modobj = CPANPLUS::Module::Fake->new(
729             module => $guess,
730             version => $version,
731             package => $dist,
732             author => CPANPLUS::Module::Author::Fake->new(
733             author => uc $author,
734             cpanid => uc $author,
735             _id => $self->_id,
736             ),
737             path => File::Spec::Unix->catdir(
738             $conf->_get_mirror('base'),
739             substr(uc $author, 0, 1),
740             substr(uc $author, 0, 2),
741             uc $author,
742             @parts, #possible subdirs
743             ),
744             _id => $self->_id,
745             );
746              
747 17         124 return $modobj;
748              
749             ### face it, we have /no/ idea what he or she wants...
750             ### let's start putting the blame somewhere
751             } else {
752              
753             # Lets not give up too easily. There is one last chance
754             # http://perlmonks.org/?node_id=805957
755             # This should catch edge-cases where the package name
756             # is unrelated to the modules it contains.
757              
758 1         38 my ($modobj) = grep { $_->package_name eq $mod }
  0         0  
759             $self->search( type => 'package', allow => [ qr/^\Q$mod\E/ ], );
760 1 50       8 return $modobj if IS_MODOBJ->( module => $modobj );
761              
762 1 50       4 unless( $author ) {
763 1         5 error( loc( "'%1' does not contain an author part", $mod ) );
764             }
765              
766 1         13 error( loc( "Cannot find '%1' in the module tree", $mod ) );
767             }
768              
769 1         16 return;
770             }
771              
772             =pod
773              
774             =head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] );
775              
776             This method reloads the source files.
777              
778             If C is set to true, this will fetch new source files
779             from your CPAN mirror. Otherwise, C will do its
780             usual cache checking and only update them if they are out of date.
781              
782             By default, C will be false.
783              
784             The verbose setting defaults to what you have specified in your
785             config file.
786              
787             Returns true on success and false on failure.
788              
789             =cut
790              
791             sub reload_indices {
792 21     21 1 11324 my $self = shift;
793 21         192 my %hash = @_;
794 21         112 my $conf = $self->configure_object;
795              
796 21         463 my $tmpl = {
797             update_source => { default => 0, allow => [qr/^\d$/] },
798             verbose => { default => $conf->get_conf('verbose') },
799             };
800              
801 21 50       151 my $args = check( $tmpl, \%hash ) or return;
802              
803             ### make a call to the internal _module_tree, so it triggers cache
804             ### file age
805 21         3325 my $uptodate = $self->_check_trees( %$args );
806              
807              
808 21 50       262 return 1 if $self->_build_trees(
809             uptodate => $uptodate,
810             use_stored => 0,
811             verbose => $conf->get_conf('verbose'),
812             );
813              
814 0         0 error( loc( "Error rebuilding source trees!" ) );
815              
816 0         0 return;
817             }
818              
819             =pod
820              
821             =head2 $bool = $cb->flush(CACHE_NAME)
822              
823             This method allows flushing of caches.
824             There are several things which can be flushed:
825              
826             =over 4
827              
828             =item * C
829              
830             The return status of methods which have been attempted, such as
831             different ways of fetching files. It is recommended that automatic
832             flushing be used instead.
833              
834             =item * C
835              
836             The return status of URIs which have been attempted, such as
837             different hosts of fetching files. It is recommended that automatic
838             flushing be used instead.
839              
840             =item * C
841              
842             Information about modules such as prerequisites and whether
843             installation succeeded, failed, or was not attempted.
844              
845             =item * C
846              
847             This resets PERL5LIB, which is changed to ensure that while installing
848             modules they are in our @INC.
849              
850             =item * C
851              
852             This resets the cache of modules we've attempted to load, but failed.
853             This enables you to load them again after a failed load, if they
854             somehow have become available.
855              
856             =item * C
857              
858             Flush all of the aforementioned caches.
859              
860             =back
861              
862             Returns true on success and false on failure.
863              
864             =cut
865              
866             sub flush {
867 7     7 1 3461 my $self = shift;
868 7 50       63 my $type = shift or return;
869              
870 7         163 my $cache = {
871             methods => [ qw( methods load ) ],
872             hosts => [ qw( hosts ) ],
873             modules => [ qw( modules lib) ],
874             lib => [ qw( lib ) ],
875             load => [ qw( load ) ],
876             all => [ qw( hosts lib modules methods load ) ],
877             };
878              
879 7 50       45 my $aref = $cache->{$type}
880             or (
881             error( loc("No such cache '%1'", $type) ),
882             return
883             );
884              
885 7         84 return $self->_flush( list => $aref );
886             }
887              
888             =pod
889              
890             =head2 @mods = $cb->installed()
891              
892             Returns a list of module objects of all your installed modules.
893             If an error occurs, it will return false.
894              
895             See L for the operations you can perform on a
896             module object.
897              
898             =cut
899              
900             sub installed {
901 2     2 1 317 my $self = shift;
902 2         62 my $aref = $self->_all_installed;
903              
904 2 50       79 return @$aref if $aref;
905 0         0 return;
906             }
907              
908             =pod
909              
910             =head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] )
911              
912             Creates a local mirror of CPAN, of only the most recent sources in a
913             location you specify. If you set this location equal to a custom host
914             in your C you can use your local mirror to install
915             from.
916              
917             It takes the following arguments:
918              
919             =over 4
920              
921             =item path
922              
923             The location where to create the local mirror.
924              
925             =item index_files
926              
927             Enable/disable fetching of index files. You can disable fetching of the
928             index files if you don't plan to use the local mirror as your primary
929             site, or if you'd like up-to-date index files be fetched from elsewhere.
930              
931             Defaults to true.
932              
933             =item force
934              
935             Forces refetching of packages, even if they are there already.
936              
937             Defaults to whatever setting you have in your C.
938              
939             =item verbose
940              
941             Prints more messages about what its doing.
942              
943             Defaults to whatever setting you have in your C.
944              
945             =back
946              
947             Returns true on success and false on error.
948              
949             =cut
950              
951             sub local_mirror {
952 1     1 1 46 my $self = shift;
953 1         57 my $conf = $self->configure_object;
954 1         39 my %hash = @_;
955              
956 1         31 my($path, $index, $force, $verbose);
957 1         41 my $tmpl = {
958             path => { default => $conf->get_conf('base'),
959             store => \$path },
960             index_files => { default => 1, store => \$index },
961             force => { default => $conf->get_conf('force'),
962             store => \$force },
963             verbose => { default => $conf->get_conf('verbose'),
964             store => \$verbose },
965             };
966              
967 1 50       61 check( $tmpl, \%hash ) or return;
968              
969 1 50 33     494 unless( -d $path ) {
970 0 0       0 $self->_mkdir( dir => $path )
971             or( error( loc( "Could not create '%1', giving up", $path ) ),
972             return
973             );
974             } elsif ( ! -w _ ) {
975             error( loc( "Could not write to '%1', giving up", $path ) );
976             return;
977             }
978              
979 1         23 my $flag;
980             AUTHOR: {
981 1         38 for my $auth ( sort { $a->cpanid cmp $b->cpanid }
  1         14  
  4         99  
982 1         34 values %{$self->author_tree}
983             ) {
984              
985             MODULE: {
986 4         52 my $i;
  4         26  
987 4         62 for my $mod ( $auth->modules ) {
988 10         159 my $fetchdir = File::Spec->catdir( $path, $mod->path );
989              
990 10         64 my %opts = (
991             verbose => $verbose,
992             force => $force,
993             fetchdir => $fetchdir,
994             );
995              
996             ### only do this the for the first module ###
997 10 100       79 unless( $i++ ) {
998 4 50       194 $mod->_get_checksums_file(
999             %opts
1000             ) or (
1001             error( loc( "Could not fetch %1 file, " .
1002             "skipping author '%2'",
1003             CHECKSUMS, $auth->cpanid ) ),
1004             $flag++, next AUTHOR
1005             );
1006             }
1007              
1008 10 50       840 $mod->fetch( %opts )
1009             or( error( loc( "Could not fetch '%1'", $mod->module ) ),
1010             $flag++, next MODULE
1011             );
1012             } }
1013             } }
1014              
1015 1 50       41 if( $index ) {
1016 1         20 for my $name (qw[auth dslip mod]) {
1017 3 50       79 $self->_update_source(
1018             name => $name,
1019             verbose => $verbose,
1020             path => $path,
1021             ) or ( $flag++, next );
1022             }
1023             }
1024              
1025 1         99 return !$flag;
1026             }
1027              
1028             =pod
1029              
1030             =head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL])
1031              
1032             Writes out a snapshot of your current installation in C bundle
1033             style. This can then be used to install the same modules for a
1034             different or on a different machine by issuing the following commands:
1035              
1036             ### using the default shell:
1037             CPAN Terminal> i file://path/to/Snapshot_XXYY.pm
1038              
1039             ### using the API
1040             $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' );
1041             $modobj->install;
1042              
1043             It will, by default, write to an 'autobundle' directory under your
1044             cpanplus home directory, but you can override that by supplying a
1045             C argument.
1046              
1047             It will return the location of the output file on success and false on
1048             failure.
1049              
1050             =cut
1051              
1052             sub autobundle {
1053 1     1 1 837 my $self = shift;
1054 1         26 my $conf = $self->configure_object;
1055 1         12 my %hash = @_;
1056              
1057 1         6 my($path,$force,$verbose);
1058 1         20 my $tmpl = {
1059             force => { default => $conf->get_conf('force'), store => \$force },
1060             verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
1061             path => { default => File::Spec->catdir(
1062             $conf->get_conf('base'),
1063             $self->_perl_version( perl => $^X ),
1064             $conf->_get_build('distdir'),
1065             $conf->_get_build('autobundle') ),
1066             store => \$path },
1067             };
1068              
1069 1 50       12 check($tmpl, \%hash) or return;
1070              
1071 1 50       191 unless( -d $path ) {
1072 1 50       18 $self->_mkdir( dir => $path )
1073             or( error(loc("Could not create directory '%1'", $path ) ),
1074             return
1075             );
1076             }
1077              
1078 1         4 my $name; my $file;
1079             { ### default filename for the bundle ###
1080 1         1 my($year,$month,$day) = (localtime)[5,4,3];
  1         39  
1081 1         5 $year += 1900; $month++;
  1         2  
1082              
1083 1         4 my $ext = 0;
1084              
1085 1         11 my $prefix = $conf->_get_build('autobundle_prefix');
1086 1         13 my $format = "${prefix}_%04d_%02d_%02d_%02d";
1087              
1088             BLOCK: {
1089 1         3 $name = sprintf( $format, $year, $month, $day, $ext);
  1         7  
1090              
1091 1         13 $file = File::Spec->catfile( $path, $name . '.pm' );
1092              
1093 1 50 0     32 -f $file ? ++$ext && redo BLOCK : last BLOCK;
1094             }
1095             }
1096 1         4 my $fh;
1097 1 50       10 unless( $fh = FileHandle->new( ">$file" ) ) {
1098 0         0 error( loc( "Could not open '%1' for writing: %2", $file, $! ) );
1099 0         0 return;
1100             }
1101              
1102             ### make sure we load the module tree *before* doing this, as it
1103             ### starts to chdir all over the place
1104 1         127 $self->module_tree;
1105              
1106             my $string = join "\n\n",
1107             map {
1108 2   50     15 join ' ',
1109             $_->module,
1110             ($_->installed_version(verbose => 0) || 'undef')
1111             } sort {
1112 1         6 $a->module cmp $b->module
  1         20  
1113             } $self->installed;
1114              
1115 1         54 my $now = scalar localtime;
1116 1         9 my $head = '=head1';
1117 1         5 my $pkg = __PACKAGE__;
1118 1         20 my $version = $self->VERSION;
1119 1         26217 my $perl_v = join '', `$^X -V`;
1120              
1121 1         294 print $fh <
1122             package $name;
1123              
1124             \$VERSION = "0.9914";
1125              
1126             1;
1127              
1128             __END__