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