File Coverage

lib/CPANPLUS/Backend.pm
Criterion Covered Total %
statement 221 240 92.1
branch 62 96 64.6
condition 25 39 64.1
subroutine 27 27 100.0
pod 11 11 100.0
total 346 413 83.8


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