This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
update to CPANPLUS 0.88
[perl5.git] / lib / CPANPLUS / Backend.pm
1 package CPANPLUS::Backend;
2
3 use strict;
4
5
6 use CPANPLUS::Error;
7 use CPANPLUS::Configure;
8 use CPANPLUS::Internals;
9 use CPANPLUS::Internals::Constants;
10 use CPANPLUS::Module;
11 use CPANPLUS::Module::Author;
12 use CPANPLUS::Backend::RV;
13
14 use FileHandle;
15 use File::Spec                  ();
16 use File::Spec::Unix            ();
17 use File::Basename              ();
18 use Params::Check               qw[check];
19 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
20
21 $Params::Check::VERBOSE = 1;
22
23 use vars qw[@ISA $VERSION];
24
25 @ISA     = qw[CPANPLUS::Internals];
26 $VERSION = $CPANPLUS::Internals::VERSION;
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
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<CPANPLUS>
61 libraries.
62
63 =head1 ENVIRONMENT
64
65 When C<CPANPLUS::Backend> is loaded, which is necessary for just
66 about every <CPANPLUS> operation, the environment variable
67 C<PERL5_CPANPLUS_IS_RUNNING> is set to the current process id.
68
69 Additionally, the environment variable C<PERL5_CPANPLUS_IS_VERSION> 
70 will be set to the version of C<CPANPLUS::Backend>.
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<CPANPLUS::Backend> 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<CPANPLUS::Configure> 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<CPANPLUS::Backend> object on success and die on
95 failure.
96
97 =cut
98
99 sub new {
100     my $class   = shift;
101     my $conf;
102
103     if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) {
104         $conf = shift;
105     } else {
106         $conf = CPANPLUS::Configure->new() or return;
107     }
108
109     my $self = $class->SUPER::_init( _conf => $conf );
110
111     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<module_tree> will try to look up these module names and
122 return the corresponding module objects instead.
123
124 See L<CPANPLUS::Module> for the operations you can perform on a
125 module object.
126
127 =cut
128
129 sub module_tree {
130     my $self    = shift;
131     my $modtree = $self->_module_tree;
132
133     if( @_ ) {
134         my @rv;
135         for my $name ( grep { defined } @_) {
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             my ($modobj) = do {
148                 ON_VMS
149                     ? $self->search(
150                           type    => 'module',
151                           allow   => [qr/^$name$/i],
152                       )
153                     : $modtree->{$name}
154             };
155             
156             push @rv, $modobj || '';
157         }
158         return @rv == 1 ? $rv[0] : @rv;
159     } else {
160         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<author_tree> will try to look up these author names and
172 return the corresponding author objects instead.
173
174 See L<CPANPLUS::Module::Author> for the operations you can perform on
175 an author object.
176
177 =cut
178
179 sub author_tree {
180     my $self        = shift;
181     my $authtree    = $self->_author_tree;
182
183     if( @_ ) {
184         my @rv;
185         for my $name (@_) {
186             push @rv, $authtree->{$name} || '';
187         }
188         return @rv == 1 ? $rv[0] : @rv;
189     } else {
190         return $authtree;
191     }
192 }
193
194 =pod
195
196 =head2 $conf = $cb->configure_object;
197
198 Returns a copy of the C<CPANPLUS::Configure> object.
199
200 See L<CPANPLUS::Configure> for operations you can perform on a
201 configure object.
202
203 =cut
204
205 sub configure_object { return shift->_conf() };
206
207 =head2 $su = $cb->selfupdate_object;
208
209 Returns a copy of the C<CPANPLUS::Selfupdate> object.
210
211 See the L<CPANPLUS::Selfupdate> manpage for the operations
212 you can perform on the selfupdate object.
213
214 =cut
215
216 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<search> enables you to search for either module or author objects,
223 based on their data. The C<type> you can specify is any of the
224 accessors specified in C<CPANPLUS::Module::Author> or
225 C<CPANPLUS::Module>. C<search> will determine by the C<type> 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<Params::Check>, so read that manpage for details.
231
232 The search is an C<or> search, meaning that if C<any> 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<data> 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<and> searches.
238
239 Returns a list of module or author objects on success and false
240 on failure.
241
242 See L<CPANPLUS::Module> for the operations you can perform on a
243 module object.
244 See L<CPANPLUS::Module::Author> for the operations you can perform on
245 an author object.
246
247 =cut
248
249 sub search {
250     my $self = shift;
251     my $conf = $self->configure_object;
252     my %hash = @_;
253
254     my ($type);
255     my $args = do {
256         local $Params::Check::NO_DUPLICATES = 0;
257         local $Params::Check::ALLOW_UNKNOWN = 1;
258
259         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         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     my $aref;
271     if( grep { $type eq $_ } CPANPLUS::Module::Author->accessors() ) {
272         $aref = $self->_search_author_tree( %$args );
273     } else {
274         $aref = $self->_search_module_tree( %$args );
275     }
276
277     return @$aref if $aref;
278     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<parse_module> can understand.
288
289 See the equivalent method in C<CPANPLUS::Module> 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<CPANPLUS::Backend::RV> 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<parse_module> can understand.
301
302 See the equivalent method in C<CPANPLUS::Module> 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<CPANPLUS::Backend::RV> 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<parse_module> can understand.
314
315 See the equivalent method in C<CPANPLUS::Module> 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<CPANPLUS::Backend::RV> 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<parse_module> can understand.
327
328 See the equivalent method in C<CPANPLUS::Module> 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<CPANPLUS::Backend::RV> 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<parse_module> can understand.
340
341 See the equivalent method in C<CPANPLUS::Module> 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<CPANPLUS::Backend::RV> 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<parse_module> can understand.
354
355 See the equivalent method in C<CPANPLUS::Module> 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<CPANPLUS::Backend::RV> object. Please consult
360 that module's documentation on how to interpret the return value.
361
362 =cut
363
364 ### XXX add direcotry_tree, packlist etc? or maybe remove files? ###
365 for my $func (qw[fetch extract install readme files distributions]) {
366     no strict 'refs';
367
368     *$func = sub {
369         my $self = shift;
370         my $conf = $self->configure_object;
371         my %hash = @_;
372
373         my ($mods);
374         my $args = do {
375             local $Params::Check::NO_DUPLICATES = 1;
376             local $Params::Check::ALLOW_UNKNOWN = 1;
377
378             my $tmpl = {
379                 modules     => { default  => [],    strict_type => 1,
380                                  required => 1,     store => \$mods },
381             };
382
383             check( $tmpl, \%hash );
384         } or return;
385
386         ### make them all into module objects ###
387         my %mods = map { $_ => $self->parse_module(module => $_) || '' } @$mods;
388
389         my $flag; my $href;
390         while( my($name,$obj) = each %mods ) {
391             $href->{$name} = IS_MODOBJ->( mod => $obj )
392                                 ? $obj->$func( %$args )
393                                 : undef;
394
395             $flag++ unless $href->{$name};
396         }
397
398         return CPANPLUS::Backend::RV->new(
399                     function    => $func,
400                     ok          => !$flag,
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<parse_module> tries to find a C<CPANPLUS::Module> object that
412 matches your query. Here's a list of examples you could give to
413 C<parse_module>;
414
415 =over 4
416
417 =item Text::Bastardize
418
419 =item Text-Bastardize
420
421 =item Text-Bastardize-1.06
422
423 =item AYRNIEU/Text-Bastardize
424
425 =item AYRNIEU/Text-Bastardize-1.06
426
427 =item AYRNIEU/Text-Bastardize-1.06.tar.gz
428
429 =item http://example.com/Text-Bastardize-1.06.tar.gz
430
431 =item file:///tmp/Text-Bastardize-1.06.tar.gz
432
433 =item /tmp/Text-Bastardize-1.06
434
435 =item ./Text-Bastardize-1.06
436
437 =item .
438
439 =back
440
441 These items would all come up with a C<CPANPLUS::Module> object for
442 C<Text::Bastardize>. The ones marked explicitly as being version 1.06
443 would give back a C<CPANPLUS::Module> object of that version.
444 Even if the version on CPAN is currently higher.
445
446 The last three are examples of PATH resolution. In the first, we supply
447 an absolute path to the unwrapped distribution. In the second the 
448 distribution is relative to the current working directory.
449 In the third, we will use the current working directory.
450
451 If C<parse_module> is unable to actually find the module you are looking
452 for in its module tree, but you supplied it with an author, module
453 and version part in a distribution name or URI, it will create a fake
454 C<CPANPLUS::Module> object for you, that you can use just like the
455 real thing.
456
457 See L<CPANPLUS::Module> for the operations you can perform on a
458 module object.
459
460 If even this fancy guessing doesn't enable C<parse_module> to create
461 a fake module object for you to use, it will warn about an error and
462 return false.
463
464 =cut
465
466 sub parse_module {
467     my $self = shift;
468     my $conf = $self->configure_object;
469     my %hash = @_;
470
471     my $mod;
472     my $tmpl = {
473         module  => { required => 1, store => \$mod },
474     };
475
476     my $args = check( $tmpl, \%hash ) or return;
477
478     return $mod if IS_MODOBJ->( module => $mod );
479
480     ### ok, so it's not a module object, but a ref nonetheless?
481     ### what are you smoking?
482     if( ref $mod ) {
483         error(loc("Can not parse module string from reference '%1'", $mod ));
484         return;
485     }
486     
487     ### check only for allowed characters in a module name
488     unless( $mod =~ /[^\w:]/ ) {
489
490         ### perhaps we can find it in the module tree?
491         my $maybe = $self->module_tree($mod);
492         return $maybe if IS_MODOBJ->( module => $maybe );
493     }
494
495     ### Special case arbitary file paths such as '.' etc.
496     if (-d File::Spec->rel2abs($mod) ) {
497         my $dir    = File::Spec->rel2abs($mod);
498         my $parent = File::Spec->rel2abs( File::Spec->catdir( $dir, '..' ) );
499
500         ### fix paths on VMS
501         if (ON_VMS) {
502             $dir    = VMS::Filespec::unixify($dir);
503             $parent = VMS::Filespec::unixify($parent);
504         }
505
506         my $dist   = $mod = File::Basename::basename($dir);
507         $dist     .= '-0'      unless $dist =~ /\-[0-9._]+$/;
508         $dist     .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
509
510         my $modobj = CPANPLUS::Module::Fake->new(
511                         module  => $mod,
512                         version => 0,
513                         package => $dist,
514                         path    => $parent,
515                         author  => CPANPLUS::Module::Author::Fake->new
516                     );
517
518         ### better guess for the version
519         $modobj->version( $modobj->package_version ) 
520             if defined $modobj->package_version;
521         
522         ### better guess at module name, if possible
523         if ( my $pkgname = $modobj->package_name ) {
524             $pkgname =~ s/-/::/g;
525         
526             ### no sense replacing it unless we changed something
527             $modobj->module( $pkgname ) 
528                 if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
529         }                
530
531         $modobj->status->fetch( $parent );
532         $modobj->status->extract( $dir );
533         $modobj->get_installer_type;
534         return $modobj;
535     }
536
537     ### ok, so it looks like a distribution then?
538     my @parts   = split '/', $mod;
539     my $dist    = pop @parts;
540
541     ### ah, it's a URL
542     if( $mod =~ m|\w+://.+| ) {
543         my $modobj = CPANPLUS::Module::Fake->new(
544                         module  => $dist,
545                         version => 0,
546                         package => $dist,
547                         path    => File::Spec::Unix->catdir(
548                                         $conf->_get_mirror('base'),
549                                         UNKNOWN_DL_LOCATION ),
550                         author  => CPANPLUS::Module::Author::Fake->new
551                     );
552         
553         ### set the fetch_from accessor so we know to by pass the
554         ### usual mirrors
555         $modobj->status->_fetch_from( $mod );
556         
557         ### better guess for the version
558         $modobj->version( $modobj->package_version ) 
559             if defined $modobj->package_version;
560         
561         ### better guess at module name, if possible
562         if ( my $pkgname = $modobj->package_name ) {
563             $pkgname =~ s/-/::/g;
564         
565             ### no sense replacing it unless we changed something
566             $modobj->module( $pkgname ) 
567                 if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
568         }                
569         
570         return $modobj;      
571     }
572     
573     ### perhaps we can find it's a third party module?
574     {   my $modobj = CPANPLUS::Module::Fake->new(
575                         module  => $mod,
576                         version => 0,
577                         package => $dist,
578                         path    => File::Spec::Unix->catdir(
579                                         $conf->_get_mirror('base'),
580                                         UNKNOWN_DL_LOCATION ),
581                         author  => CPANPLUS::Module::Author::Fake->new
582                     );
583         if( $modobj->is_third_party ) {
584             my $info = $modobj->third_party_information;
585             
586             $modobj->author->author( $info->{author}     );
587             $modobj->author->email(  $info->{author_url} );
588             $modobj->description(    $info->{url} );
589
590             return $modobj;
591         }
592     }
593
594     unless( $dist ) {
595         error( loc("%1 is not a proper distribution name!", $mod) );
596         return;
597     }
598     
599     ### there's wonky uris out there, like this:
600     ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091
601     ### compensate for that
602     my $author;
603     ### you probably have an A/AB/ABC/....../Dist.tgz type uri
604     if( (defined $parts[0] and length $parts[0] == 1) and 
605         (defined $parts[1] and length $parts[1] == 2) and
606         $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i
607     ) {   
608         splice @parts, 0, 2;    # remove the first 2 entries from the list
609         $author = shift @parts; # this is the actual author name then    
610
611     ### we''ll assume a ABC/..../Dist.tgz
612     } else {
613         $author = shift @parts || '';
614     }
615
616     my($pkg, $version, $ext, $full) = 
617         $self->_split_package_string( package => $dist );
618     
619     ### translate a distribution into a module name ###
620     my $guess = $pkg; 
621     $guess =~ s/-/::/g if $guess; 
622
623     my $maybe = $self->module_tree( $guess );
624     if( IS_MODOBJ->( module => $maybe ) ) {
625
626         ### maybe you asked for a package instead
627         if ( $maybe->package eq $mod ) {
628             return $maybe;
629
630         ### perhaps an outdated version instead?
631         } elsif ( $version ) {
632             my $auth_obj; my $path;
633
634             ### did you give us an author part? ###
635             if( $author ) {
636                 $auth_obj   = CPANPLUS::Module::Author::Fake->new(
637                                     _id     => $maybe->_id,
638                                     cpanid  => uc $author,
639                                     author  => uc $author,
640                                 );
641                 $path       = File::Spec::Unix->catdir(
642                                     $conf->_get_mirror('base'),
643                                     substr(uc $author, 0, 1),
644                                     substr(uc $author, 0, 2),
645                                     uc $author,
646                                     @parts,     #possible sub dirs
647                                 );
648             } else {
649                 $auth_obj   = $maybe->author;
650                 $path       = $maybe->path;
651             }        
652         
653             if( $maybe->package_name eq $pkg ) {
654     
655                 my $modobj = CPANPLUS::Module::Fake->new(
656                     module  => $maybe->module,
657                     version => $version,
658                     ### no extension? use the extension the original package
659                     ### had instead
660                     package => do { $ext 
661                                         ? $full 
662                                         : $full .'.'. $maybe->package_extension 
663                                 },
664                     path    => $path,
665                     author  => $auth_obj,
666                     _id     => $maybe->_id
667                 );
668                 return $modobj;
669
670             ### you asked for a specific version?
671             ### assume our $maybe is the one you wanted,
672             ### and fix up the version.. 
673             } else {
674     
675                 my $modobj = $maybe->clone;
676                 $modobj->version( $version );
677                 $modobj->package( 
678                         $maybe->package_name .'-'. 
679                         $version .'.'. 
680                         $maybe->package_extension 
681                 );
682                 
683                 ### you wanted a specific author, but it's not the one
684                 ### from the module tree? we'll fix it up
685                 if( $author and $author ne $modobj->author->cpanid ) {
686                     $modobj->author( $auth_obj );
687                     $modobj->path( $path );
688                 }
689                 
690                 return $modobj;
691             }
692         
693         ### you didn't care about a version, so just return the object then
694         } elsif ( !$version ) {
695             return $maybe;
696         }
697
698     ### ok, so we can't find it, and it's not an outdated dist either
699     ### perhaps we can fake one based on the author name and so on
700     } elsif ( $author and $version ) {
701
702         ### be extra friendly and pad the .tar.gz suffix where needed
703         ### it's just a guess of course, but most dists are .tar.gz
704         $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
705
706         ### XXX duplication from above for generating author obj + path...
707         my $modobj = CPANPLUS::Module::Fake->new(
708             module  => $guess,
709             version => $version,
710             package => $dist,
711             author  => CPANPLUS::Module::Author::Fake->new(
712                             author  => uc $author,
713                             cpanid  => uc $author,
714                             _id     => $self->_id,
715                         ),
716             path    => File::Spec::Unix->catdir(
717                             $conf->_get_mirror('base'),
718                             substr(uc $author, 0, 1),
719                             substr(uc $author, 0, 2),
720                             uc $author,
721                             @parts,         #possible subdirs
722                         ),
723             _id     => $self->_id,
724         );
725
726         return $modobj;
727
728     ### face it, we have /no/ idea what he or she wants...
729     ### let's start putting the blame somewhere
730     } else {
731
732         unless( $author ) {
733             error( loc( "'%1' does not contain an author part", $mod ) );
734         }
735
736         error( loc( "Cannot find '%1' in the module tree", $mod ) );
737     }
738
739     return;
740 }
741
742 =pod
743
744 =head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] );
745
746 This method reloads the source files.
747
748 If C<update_source> is set to true, this will fetch new source files
749 from your CPAN mirror. Otherwise, C<reload_indices> will do its
750 usual cache checking and only update them if they are out of date.
751
752 By default, C<update_source> will be false.
753
754 The verbose setting defaults to what you have specified in your
755 config file.
756
757 Returns true on success and false on failure.
758
759 =cut
760
761 sub reload_indices {
762     my $self    = shift;
763     my %hash    = @_;
764     my $conf    = $self->configure_object;
765
766     my $tmpl = {
767         update_source   => { default    => 0, allow => [qr/^\d$/] },
768         verbose         => { default    => $conf->get_conf('verbose') },
769     };
770
771     my $args = check( $tmpl, \%hash ) or return;
772
773     ### make a call to the internal _module_tree, so it triggers cache
774     ### file age
775     my $uptodate = $self->_check_trees( %$args );
776
777
778     return 1 if $self->_build_trees(
779                                 uptodate    => $uptodate,
780                                 use_stored  => 0,
781                                 verbose     => $conf->get_conf('verbose'),
782                             );
783
784     error( loc( "Error rebuilding source trees!" ) );
785
786     return;
787 }
788
789 =pod
790
791 =head2 $bool = $cb->flush(CACHE_NAME)
792
793 This method allows flushing of caches.
794 There are several things which can be flushed:
795
796 =over 4
797
798 =item * C<methods>
799
800 The return status of methods which have been attempted, such as
801 different ways of fetching files.  It is recommended that automatic
802 flushing be used instead.
803
804 =item * C<hosts>
805
806 The return status of URIs which have been attempted, such as
807 different hosts of fetching files.  It is recommended that automatic
808 flushing be used instead.
809
810 =item * C<modules>
811
812 Information about modules such as prerequisites and whether
813 installation succeeded, failed, or was not attempted.
814
815 =item * C<lib>
816
817 This resets PERL5LIB, which is changed to ensure that while installing
818 modules they are in our @INC.
819
820 =item * C<load>
821
822 This resets the cache of modules we've attempted to load, but failed.
823 This enables you to load them again after a failed load, if they 
824 somehow have become available.
825
826 =item * C<all>
827
828 Flush all of the aforementioned caches.
829
830 =back
831
832 Returns true on success and false on failure.
833
834 =cut
835
836 sub flush {
837     my $self = shift;
838     my $type = shift or return;
839
840     my $cache = {
841         methods => [ qw( methods load ) ],
842         hosts   => [ qw( hosts ) ],
843         modules => [ qw( modules lib) ],
844         lib     => [ qw( lib ) ],
845         load    => [ qw( load ) ],
846         all     => [ qw( hosts lib modules methods load ) ],
847     };
848
849     my $aref = $cache->{$type}
850                     or (
851                         error( loc("No such cache '%1'", $type) ),
852                         return
853                     );
854
855     return $self->_flush( list => $aref );
856 }
857
858 =pod
859
860 =head2 @mods = $cb->installed()
861
862 Returns a list of module objects of all your installed modules.
863 If an error occurs, it will return false.
864
865 See L<CPANPLUS::Module> for the operations you can perform on a
866 module object.
867
868 =cut
869
870 sub installed {
871     my $self = shift;
872     my $aref = $self->_all_installed;
873
874     return @$aref if $aref;
875     return;
876 }
877
878 =pod
879
880 =head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] )
881
882 Creates a local mirror of CPAN, of only the most recent sources in a
883 location you specify. If you set this location equal to a custom host
884 in your C<CPANPLUS::Config> you can use your local mirror to install
885 from.
886
887 It takes the following arguments:
888
889 =over 4
890
891 =item path
892
893 The location where to create the local mirror.
894
895 =item index_files
896
897 Enable/disable fetching of index files. You can disable fetching of the
898 index files if you don't plan to use the local mirror as your primary 
899 site, or if you'd like up-to-date index files be fetched from elsewhere.
900
901 Defaults to true.
902
903 =item force
904
905 Forces refetching of packages, even if they are there already.
906
907 Defaults to whatever setting you have in your C<CPANPLUS::Config>.
908
909 =item verbose
910
911 Prints more messages about what its doing.
912
913 Defaults to whatever setting you have in your C<CPANPLUS::Config>.
914
915 =back
916
917 Returns true on success and false on error.
918
919 =cut
920
921 sub local_mirror {
922     my $self = shift;
923     my $conf = $self->configure_object;
924     my %hash = @_;
925
926     my($path, $index, $force, $verbose);
927     my $tmpl = {
928         path        => { default => $conf->get_conf('base'),
929                             store => \$path },
930         index_files => { default => 1, store => \$index },
931         force       => { default => $conf->get_conf('force'),
932                             store => \$force },
933         verbose     => { default => $conf->get_conf('verbose'),
934                             store => \$verbose },
935     };
936
937     check( $tmpl, \%hash ) or return;
938
939     unless( -d $path ) {
940         $self->_mkdir( dir => $path )
941                 or( error( loc( "Could not create '%1', giving up", $path ) ),
942                     return
943                 );
944     } elsif ( ! -w _ ) {
945         error( loc( "Could not write to '%1', giving up", $path ) );
946         return;
947     }
948
949     my $flag;
950     AUTHOR: {
951     for my $auth (  sort { $a->cpanid cmp $b->cpanid }
952                     values %{$self->author_tree}
953     ) {
954
955         MODULE: {
956         my $i;
957         for my $mod ( $auth->modules ) {
958             my $fetchdir = File::Spec->catdir( $path, $mod->path );
959
960             my %opts = (
961                 verbose     => $verbose,
962                 force       => $force,
963                 fetchdir    => $fetchdir,
964             );
965
966             ### only do this the for the first module ###
967             unless( $i++ ) {
968                 $mod->_get_checksums_file(
969                             %opts
970                         ) or (
971                             error( loc( "Could not fetch %1 file, " .
972                                         "skipping author '%2'",
973                                         CHECKSUMS, $auth->cpanid ) ),
974                             $flag++, next AUTHOR
975                         );
976             }
977
978             $mod->fetch( %opts )
979                     or( error( loc( "Could not fetch '%1'", $mod->module ) ),
980                         $flag++, next MODULE
981                     );
982         } }
983     } }
984
985     if( $index ) {
986         for my $name (qw[auth dslip mod]) {
987             $self->_update_source(
988                         name    => $name,
989                         verbose => $verbose,
990                         path    => $path,
991                     ) or ( $flag++, next );
992         }
993     }
994
995     return !$flag;
996 }
997
998 =pod
999
1000 =head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL])
1001
1002 Writes out a snapshot of your current installation in C<CPAN> bundle
1003 style. This can then be used to install the same modules for a
1004 different or on a different machine by issuing the following commands:
1005
1006     ### using the default shell:
1007     CPAN Terminal> i file://path/to/Snapshot_XXYY.pm
1008     
1009     ### using the API
1010     $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' );
1011     $modobj->install;
1012
1013 It will, by default, write to an 'autobundle' directory under your
1014 cpanplus homedirectory, but you can override that by supplying a
1015 C<path> argument.
1016
1017 It will return the location of the output file on success and false on
1018 failure.
1019
1020 =cut
1021
1022 sub autobundle {
1023     my $self = shift;
1024     my $conf = $self->configure_object;
1025     my %hash = @_;
1026
1027     my($path,$force,$verbose);
1028     my $tmpl = {
1029         force   => { default => $conf->get_conf('force'), store => \$force },
1030         verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
1031         path    => { default => File::Spec->catdir(
1032                                         $conf->get_conf('base'),
1033                                         $self->_perl_version( perl => $^X ),
1034                                         $conf->_get_build('distdir'),
1035                                         $conf->_get_build('autobundle') ),
1036                     store => \$path },
1037     };
1038
1039     check($tmpl, \%hash) or return;
1040
1041     unless( -d $path ) {
1042         $self->_mkdir( dir => $path )
1043                 or( error(loc("Could not create directory '%1'", $path ) ),
1044                     return
1045                 );
1046     }
1047
1048     my $name; my $file;
1049     {   ### default filename for the bundle ###
1050         my($year,$month,$day) = (localtime)[5,4,3];
1051         $year += 1900; $month++;
1052
1053         my $ext = 0;
1054
1055         my $prefix  = $conf->_get_build('autobundle_prefix');
1056         my $format  = "${prefix}_%04d_%02d_%02d_%02d";
1057
1058         BLOCK: {
1059             $name = sprintf( $format, $year, $month, $day, $ext);
1060
1061             $file = File::Spec->catfile( $path, $name . '.pm' );
1062
1063             -f $file ? ++$ext && redo BLOCK : last BLOCK;
1064         }
1065     }
1066     my $fh;
1067     unless( $fh = FileHandle->new( ">$file" ) ) {
1068         error( loc( "Could not open '%1' for writing: %2", $file, $! ) );
1069         return;
1070     }
1071     
1072     ### make sure we load the module tree *before* doing this, as it
1073     ### starts to chdir all over the place
1074     $self->module_tree;
1075
1076     my $string = join "\n\n",
1077                     map {
1078                         join ' ',
1079                             $_->module,
1080                             ($_->installed_version(verbose => 0) || 'undef')
1081                     } sort {
1082                         $a->module cmp $b->module
1083                     }  $self->installed;
1084
1085     my $now     = scalar localtime;
1086     my $head    = '=head1';
1087     my $pkg     = __PACKAGE__;
1088     my $version = $self->VERSION;
1089     my $perl_v  = join '', `$^X -V`;
1090
1091     print $fh <<EOF;
1092 package $name;
1093
1094 \$VERSION = '0.01';
1095
1096 1;
1097
1098 __END__
1099
1100 $head NAME
1101
1102 $name - Snapshot of your installation at $now
1103
1104 $head SYNOPSIS
1105
1106 To install the modules from this snapshot, run:
1107
1108   cpanp -i file://full/path/to/${name}.pm
1109
1110 $head CONTENTS
1111
1112 $string
1113
1114 $head CONFIGURATION
1115
1116 $perl_v
1117
1118 $head AUTHOR
1119
1120 This bundle has been generated autotomatically by
1121     $pkg $version
1122
1123 EOF
1124
1125     close $fh;
1126
1127     return $file;
1128 }
1129
1130 =head2 $bool = $cb->save_state
1131
1132 Explicit command to save memory state to disk. This can be used to save
1133 information to disk about where a module was extracted, the result of 
1134 C<make test>, etc. This will then be re-loaded into memory when a new
1135 session starts.
1136
1137 The capability of saving state to disk depends on the source engine
1138 being used (See C<CPANPLUS::Config> for the option to choose your
1139 source engine). The default storage engine supports this option.
1140
1141 Most users will not need this command, but it can handy for automated
1142 systems like setting up CPAN smoke testers.
1143
1144 The method will return true if it managed to save the state to disk, 
1145 or false if it did not.
1146
1147 =cut
1148
1149 sub save_state {
1150     my $self = shift;
1151     return $self->_save_state( @_ );
1152 }
1153
1154
1155 ### XXX these wrappers are not individually tested! only the underlying
1156 ### code through source.t and indirectly trought he CustomSource plugin.
1157 =pod
1158
1159 =head1 CUSTOM MODULE SOURCES
1160
1161 Besides the sources as provided by the general C<CPAN> mirrors, it's 
1162 possible to add your own sources list to your C<CPANPLUS> index.
1163
1164 The methodology behind this works much like C<Debian's apt-sources>.
1165
1166 The methods below show you how to make use of this functionality. Also
1167 note that most of these methods are available through the default shell
1168 plugin command C</cs>, making them available as shortcuts through the
1169 shell and via the commandline.
1170
1171 =head2 %files = $cb->list_custom_sources
1172
1173 Returns a mapping of registered custom sources and their local indices
1174 as follows:
1175
1176     /full/path/to/local/index => http://remote/source
1177
1178 Note that any file starting with an C<#> is being ignored.
1179
1180 =cut
1181
1182 sub list_custom_sources {
1183     return shift->__list_custom_module_sources( @_ );
1184 }
1185
1186 =head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] );
1187
1188 Adds an C<URI> to your own sources list and mirrors its index. See the 
1189 documentation on C<< $cb->update_custom_source >> on how this is done.
1190
1191 Returns the full path to the local index on success, or false on failure.
1192
1193 Note that when adding a new C<URI>, the change to the in-memory tree is
1194 not saved until you rebuild or save the tree to disk again. You can do 
1195 this using the C<< $cb->reload_indices >> method.
1196
1197 =cut
1198
1199 sub add_custom_source {
1200     return shift->_add_custom_module_source( @_ );
1201 }
1202
1203 =head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] );
1204
1205 Removes an C<URI> from your own sources list and removes its index.
1206
1207 To find out what C<URI>s you have as part of your own sources list, use
1208 the C<< $cb->list_custom_sources >> method.
1209
1210 Returns the full path to the deleted local index file on success, or false
1211 on failure.
1212
1213 =cut
1214
1215 ### XXX do clever dispatching based on arg number?
1216 sub remove_custom_source {
1217     return shift->_remove_custom_module_source( @_ );
1218 }
1219
1220 =head2 $bool = $cb->update_custom_source( [remote => URI] );
1221
1222 Updates the indexes for all your custom sources. It does this by fetching
1223 a file called C<packages.txt> in the root of the custom sources's C<URI>.
1224 If you provide the C<remote> argument, it will only update the index for
1225 that specific C<URI>.
1226
1227 Here's an example of how custom sources would resolve into index files:
1228
1229   file:///path/to/sources       =>  file:///path/to/sources/packages.txt
1230   http://example.com/sources    =>  http://example.com/sources/packages.txt
1231   ftp://example.com/sources     =>  ftp://example.com/sources/packages.txt
1232   
1233 The file C<packages.txt> simply holds a list of packages that can be found
1234 under the root of the C<URI>. This file can be automatically generated for
1235 you when the remote source is a C<file:// URI>. For C<http://>, C<ftp://>,
1236 and similar, the administrator of that repository should run the method
1237 C<< $cb->write_custom_source_index >> on the repository to allow remote
1238 users to index it.
1239
1240 For details, see the C<< $cb->write_custom_source_index >> method below.
1241
1242 All packages that are added via this mechanism will be attributed to the
1243 author with C<CPANID> C<LOCAL>. You can use this id to search for all 
1244 added packages.
1245
1246 =cut
1247
1248 sub update_custom_source {
1249     my $self = shift;
1250     
1251     ### if it mentions /remote/, the request is to update a single uri,
1252     ### not all the ones we have, so dispatch appropriately
1253     my $rv = grep( /remote/i, @_)
1254         ? $self->__update_custom_module_source( @_ )
1255         : $self->__update_custom_module_sources( @_ );
1256
1257     return $rv;
1258 }    
1259
1260 =head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] );
1261
1262 Writes the index for a custom repository root. Most users will not have to 
1263 worry about this, but administrators of a repository will need to make sure
1264 their indexes are up to date.
1265
1266 The index will be written to a file called C<packages.txt> in your repository
1267 root, which you can specify with the C<path> argument. You can override this
1268 location by specifying the C<to> argument, but in normal operation, that should
1269 not be required.
1270
1271 Once the index file is written, users can then add the C<URI> pointing to 
1272 the repository to their custom list of sources and start using it right away. See the C<< $cb->add_custom_source >> method for user details.
1273
1274 =cut
1275
1276 sub write_custom_source_index {
1277     return shift->__write_custom_module_index( @_ );
1278 }
1279
1280 1;
1281
1282 =pod
1283
1284 =head1 BUG REPORTS
1285
1286 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1287
1288 =head1 AUTHOR
1289
1290 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1291
1292 =head1 COPYRIGHT
1293
1294 The CPAN++ interface (of which this module is a part of) is copyright (c) 
1295 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1296
1297 This library is free software; you may redistribute and/or modify it 
1298 under the same terms as Perl itself.
1299
1300 =head1 SEE ALSO
1301
1302 L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>, 
1303 L<CPANPLUS::Selfupdate>
1304
1305 =cut
1306
1307 # Local variables:
1308 # c-indentation-style: bsd
1309 # c-basic-offset: 4
1310 # indent-tabs-mode: nil
1311 # End:
1312 # vim: expandtab shiftwidth=4:
1313
1314 __END__
1315
1316 todo:
1317 sub dist {          # not sure about this one -- probably already done
1318                       enough in Module.pm
1319 sub reports {       # in Module.pm, wrapper here
1320
1321