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 )
 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         return $modobj;
 479     }
 480
 481     ### perhaps we can find it's a third party module?
 482     {   my $modobj = CPANPLUS::Module::Fake->new(
 483                         module  => $mod,
 484                         version => 0,
 485                         package => $dist,
 486                         path    => File::Spec::Unix->catdir(
 487                                         $conf->_get_mirror('base'),
 488                                         UNKNOWN_DL_LOCATION ),
 489                         author  => CPANPLUS::Module::Author::Fake->new
 490                     );
 491         if( $modobj->is_third_party ) {
 492             my $info = $modobj->third_party_information;
 493
 494             $modobj->author->author( $info->{author}     );
 495             $modobj->author->email(  $info->{author_url} );
 496             $modobj->description(    $info->{url} );
 497
 498             return $modobj;
 499         }
 500     }
 501
 502     unless( $dist ) {
 503         error( loc("%1 is not a proper distribution name!", $mod) );
 504         return;
 505     }
 506
 507     ### there's wonky uris out there, like this:
 508     ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091
 509     ### compensate for that
 510     my $author;
 511     ### you probably have an A/AB/ABC/....../Dist.tgz type uri
 512     if( (defined $parts[0] and length $parts[0] == 1) and
 513         (defined $parts[1] and length $parts[1] == 2) and
 514         $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i
 515     ) {
 516         splice @parts, 0, 2;    # remove the first 2 entries from the list
 517         $author = shift @parts; # this is the actual author name then
 518
 519     ### we''ll assume a ABC/..../Dist.tgz
 520     } else {
 521         $author = shift @parts || '';
 522     }
 523
 524     my($pkg, $version, $ext) =
 525         $self->_split_package_string( package => $dist );
 526
 527     ### translate a distribution into a module name ###
 528     my $guess = $pkg;
 529     $guess =~ s/-/::/g if $guess;
 530
 531     my $maybe = $self->module_tree( $guess );
 532     if( IS_MODOBJ->( module => $maybe ) ) {
 533
 534         ### maybe you asked for a package instead
 535         if ( $maybe->package eq $mod ) {
 536             return $maybe;
 537
 538         ### perhaps an outdated version instead?
 539         } elsif ( $version ) {
 540             my $auth_obj; my $path;
 541
 542             ### did you give us an author part? ###
 543             if( $author ) {
 544                 $auth_obj   = CPANPLUS::Module::Author::Fake->new(
 545                                     _id     => $maybe->_id,
 546                                     cpanid  => uc $author,
 547                                     author  => uc $author,
 548                                 );
 549                 $path       = File::Spec::Unix->catdir(
 550                                     $conf->_get_mirror('base'),
 551                                     substr(uc $author, 0, 1),
 552                                     substr(uc $author, 0, 2),
 553                                     uc $author,
 554                                     @parts,     #possible sub dirs
 555                                 );
 556             } else {
 557                 $auth_obj   = $maybe->author;
 558                 $path       = $maybe->path;
 559             }
 560
 561             if( $maybe->package_name eq $pkg ) {
 562
 563                 my $modobj = CPANPLUS::Module::Fake->new(
 564                     module  => $maybe->module,
 565                     version => $version,
 566                     package => $pkg . '-' . $version . '.' .
 567                                     $maybe->package_extension,
 568                     path    => $path,
 569                     author  => $auth_obj,
 570                     _id     => $maybe->_id
 571                 );
 572                 return $modobj;
 573
 574             ### you asked for a specific version?
 575             ### assume our $maybe is the one you wanted,
 576             ### and fix up the version..
 577             } else {
 578
 579                 my $modobj = $maybe->clone;
 580                 $modobj->version( $version );
 581                 $modobj->package(
 582                         $maybe->package_name .'-'.
 583                         $version .'.'.
 584                         $maybe->package_extension
 585                 );
 586
 587                 ### you wanted a specific author, but it's not the one
 588                 ### from the module tree? we'll fix it up
 589                 if( $author and $author ne $modobj->author->cpanid ) {
 590                     $modobj->author( $auth_obj );
 591                     $modobj->path( $path );
 592                 }
 593
 594                 return $modobj;
 595             }
 596
 597         ### you didn't care about a version, so just return the object then
 598         } elsif ( !$version ) {
 599             return $maybe;
 600         }
 601
 602     ### ok, so we can't find it, and it's not an outdated dist either
 603     ### perhaps we can fake one based on the author name and so on
 604     } elsif ( $author and $version ) {
 605
 606         ### be extra friendly and pad the .tar.gz suffix where needed
 607         ### it's just a guess of course, but most dists are .tar.gz
 608         $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
 609
 610         ### XXX duplication from above for generating author obj + path...
 611         my $modobj = CPANPLUS::Module::Fake->new(
 612             module  => $guess,
 613             version => $version,
 614             package => $dist,
 615             author  => CPANPLUS::Module::Author::Fake->new(
 616                             author  => uc $author,
 617                             cpanid  => uc $author,
 618                             _id     => $self->_id,
 619                         ),
 620             path    => File::Spec::Unix->catdir(
 621                             $conf->_get_mirror('base'),
 622                             substr(uc $author, 0, 1),
 623                             substr(uc $author, 0, 2),
 624                             uc $author,
 625                             @parts,         #possible subdirs
 626                         ),
 627             _id     => $self->_id,
 628         );
 629
 630         return $modobj;
 631
 632     ### face it, we have /no/ idea what he or she wants...
 633     ### let's start putting the blame somewhere
 634     } else {
 635
 636         unless( $author ) {
 637             error( loc( "'%1' does not contain an author part", $mod ) );
 638         }
 639
 640         error( loc( "Cannot find '%1' in the module tree", $mod ) );
 641     }
 642
 643     return;
 644 }
 645
 646 =pod
 647
 648 =head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] );
 649
 650 This method reloads the source files.
 651
 652 If C<update_source> is set to true, this will fetch new source files
 653 from your CPAN mirror. Otherwise, C<reload_indices> will do its
 654 usual cache checking and only update them if they are out of date.
 655
 656 By default, C<update_source> will be false.
 657
 658 The verbose setting defaults to what you have specified in your
 659 config file.
 660
 661 Returns true on success and false on failure.
 662
 663 =cut
 664
 665 sub reload_indices {
 666     my $self    = shift;
 667     my %hash    = @_;
 668     my $conf    = $self->configure_object;
 669
 670     my $tmpl = {
 671         update_source   => { default    => 0, allow => [qr/^\d$/] },
 672         verbose         => { default    => $conf->get_conf('verbose') },
 673     };
 674
 675     my $args = check( $tmpl, \%hash ) or return;
 676
 677     ### make a call to the internal _module_tree, so it triggers cache
 678     ### file age
 679     my $uptodate = $self->_check_trees( %$args );
 680
 681
 682     return 1 if $self->_build_trees(
 683                                 uptodate    => $uptodate,
 684                                 use_stored  => 0,
 685                                 verbose     => $conf->get_conf('verbose'),
 686                             );
 687
 688     error( loc( "Error rebuilding source trees!" ) );
 689
 690     return;
 691 }
 692
 693 =pod
 694
 695 =head2 $bool = $cb->flush(CACHE_NAME)
 696
 697 This method allows flushing of caches.
 698 There are several things which can be flushed:
 699
 700 =over 4
 701
 702 =item * C<methods>
 703
 704 The return status of methods which have been attempted, such as
 705 different ways of fetching files.  It is recommended that automatic
 706 flushing be used instead.
 707
 708 =item * C<hosts>
 709
 710 The return status of URIs which have been attempted, such as
 711 different hosts of fetching files.  It is recommended that automatic
 712 flushing be used instead.
 713
 714 =item * C<modules>
 715
 716 Information about modules such as prerequisites and whether
 717 installation succeeded, failed, or was not attempted.
 718
 719 =item * C<lib>
 720
 721 This resets PERL5LIB, which is changed to ensure that while installing
 722 modules they are in our @INC.
 723
 724 =item * C<load>
 725
 726 This resets the cache of modules we've attempted to load, but failed.
 727 This enables you to load them again after a failed load, if they
 728 somehow have become available.
 729
 730 =item * C<all>
 731
 732 Flush all of the aforementioned caches.
 733
 734 =back
 735
 736 Returns true on success and false on failure.
 737
 738 =cut
 739
 740 sub flush {
 741     my $self = shift;
 742     my $type = shift or return;
 743
 744     my $cache = {
 745         methods => [ qw( methods load ) ],
 746         hosts   => [ qw( hosts ) ],
 747         modules => [ qw( modules lib) ],
 748         lib     => [ qw( lib ) ],
 749         load    => [ qw( load ) ],
 750         all     => [ qw( hosts lib modules methods load ) ],
 751     };
 752
 753     my $aref = $cache->{$type}
 754                     or (
 755                         error( loc("No such cache '%1'", $type) ),
 756                         return
 757                     );
 758
 759     return $self->_flush( list => $aref );
 760 }
 761
 762 =pod
 763
 764 =head2 @mods = $cb->installed()
 765
 766 Returns a list of module objects of all your installed modules.
 767 If an error occurs, it will return false.
 768
 769 See L<CPANPLUS::Module> for the operations you can perform on a
 770 module object.
 771
 772 =cut
 773
 774 sub installed {
 775     my $self = shift;
 776     my $aref = $self->_all_installed;
 777
 778     return @$aref if $aref;
 779     return;
 780 }
 781
 782 =pod
 783
 784 =head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] )
 785
 786 Creates a local mirror of CPAN, of only the most recent sources in a
 787 location you specify. If you set this location equal to a custom host
 788 in your C<CPANPLUS::Config> you can use your local mirror to install
 789 from.
 790
 791 It takes the following arguments:
 792
 793 =over 4
 794
 795 =item path
 796
 797 The location where to create the local mirror.
 798
 799 =item index_files
 800
 801 Enable/disable fetching of index files. This is ok if you don't plan
 802 to use the local mirror as your primary sites, or if you'd like
 803 up-to-date index files be fetched from elsewhere.
 804
 805 Defaults to true.
 806
 807 =item force
 808
 809 Forces refetching of packages, even if they are there already.
 810
 811 Defaults to whatever setting you have in your C<CPANPLUS::Config>.
 812
 813 =item verbose
 814
 815 Prints more messages about what its doing.
 816
 817 Defaults to whatever setting you have in your C<CPANPLUS::Config>.
 818
 819 =back
 820
 821 Returns true on success and false on error.
 822
 823 =cut
 824
 825 sub local_mirror {
 826     my $self = shift;
 827     my $conf = $self->configure_object;
 828     my %hash = @_;
 829
 830     my($path, $index, $force, $verbose);
 831     my $tmpl = {
 832         path        => { default => $conf->get_conf('base'),
 833                             store => \$path },
 834         index_files => { default => 1, store => \$index },
 835         force       => { default => $conf->get_conf('force'),
 836                             store => \$force },
 837         verbose     => { default => $conf->get_conf('verbose'),
 838                             store => \$verbose },
 839     };
 840
 841     check( $tmpl, \%hash ) or return;
 842
 843     unless( -d $path ) {
 844         $self->_mkdir( dir => $path )
 845                 or( error( loc( "Could not create '%1', giving up", $path ) ),
 846                     return
 847                 );
 848     } elsif ( ! -w _ ) {
 849         error( loc( "Could not write to '%1', giving up", $path ) );
 850         return;
 851     }
 852
 853     my $flag;
 854     AUTHOR: {
 855     for my $auth (  sort { $a->cpanid cmp $b->cpanid }
 856                     values %{$self->author_tree}
 857     ) {
 858
 859         MODULE: {
 860         my $i;
 861         for my $mod ( $auth->modules ) {
 862             my $fetchdir = File::Spec->catdir( $path, $mod->path );
 863
 864             my %opts = (
 865                 verbose     => $verbose,
 866                 force       => $force,
 867                 fetchdir    => $fetchdir,
 868             );
 869
 870             ### only do this the for the first module ###
 871             unless( $i++ ) {
 872                 $mod->_get_checksums_file(
 873                             %opts
 874                         ) or (
 875                             error( loc( "Could not fetch %1 file, " .
 876                                         "skipping author '%2'",
 877                                         CHECKSUMS, $auth->cpanid ) ),
 878                             $flag++, next AUTHOR
 879                         );
 880             }
 881
 882             $mod->fetch( %opts )
 883                     or( error( loc( "Could not fetch '%1'", $mod->module ) ),
 884                         $flag++, next MODULE
 885                     );
 886         } }
 887     } }
 888
 889     if( $index ) {
 890         for my $name (qw[auth dslip mod]) {
 891             $self->_update_source(
 892                         name    => $name,
 893                         verbose => $verbose,
 894                         path    => $path,
 895                     ) or ( $flag++, next );
 896         }
 897     }
 898
 899     return !$flag;
 900 }
 901
 902 =pod
 903
 904 =head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL])
 905
 906 Writes out a snapshot of your current installation in C<CPAN> bundle
 907 style. This can then be used to install the same modules for a
 908 different or on a different machine.
 909
 910 It will, by default, write to an 'autobundle' directory under your
 911 cpanplus homedirectory, but you can override that by supplying a
 912 C<path> argument.
 913
 914 It will return the location of the output file on success and false on
 915 failure.
 916
 917 =cut
 918
 919 sub autobundle {
 920     my $self = shift;
 921     my $conf = $self->configure_object;
 922     my %hash = @_;
 923
 924     my($path,$force,$verbose);
 925     my $tmpl = {
 926         force   => { default => $conf->get_conf('force'), store => \$force },
 927         verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
 928         path    => { default => File::Spec->catdir(
 929                                         $conf->get_conf('base'),
 930                                         $self->_perl_version( perl => $^X ),
 931                                         $conf->_get_build('distdir'),
 932                                         $conf->_get_build('autobundle') ),
 933                     store => \$path },
 934     };
 935
 936     check($tmpl, \%hash) or return;
 937
 938     unless( -d $path ) {
 939         $self->_mkdir( dir => $path )
 940                 or( error(loc("Could not create directory '%1'", $path ) ),
 941                     return
 942                 );
 943     }
 944
 945     my $name; my $file;
 946     {   ### default filename for the bundle ###
 947         my($year,$month,$day) = (localtime)[5,4,3];
 948         $year += 1900; $month++;
 949
 950         my $ext = 0;
 951
 952         my $prefix  = $conf->_get_build('autobundle_prefix');
 953         my $format  = "${prefix}_%04d_%02d_%02d_%02d";
 954
 955         BLOCK: {
 956             $name = sprintf( $format, $year, $month, $day, $ext);
 957
 958             $file = File::Spec->catfile( $path, $name . '.pm' );
 959
 960             -f $file ? ++$ext && redo BLOCK : last BLOCK;
 961         }
 962     }
 963     my $fh;
 964     unless( $fh = FileHandle->new( ">$file" ) ) {
 965         error( loc( "Could not open '%1' for writing: %2", $file, $! ) );
 966         return;
 967     }
 968
 969     my $string = join "\n\n",
 970                     map {
 971                         join ' ',
 972                             $_->module,
 973                             ($_->installed_version(verbose => 0) || 'undef')
 974                     } sort {
 975                         $a->module cmp $b->module
 976                     }  $self->installed;
 977
 978     my $now     = scalar localtime;
 979     my $head    = '=head1';
 980     my $pkg     = __PACKAGE__;
 981     my $version = $self->VERSION;
 982     my $perl_v  = join '', `$^X -V`;
 983
 984     print $fh <<EOF;
 985 package $name
 986
 987 \$VERSION = '0.01';
 988
 989 1;
 990
 991 __END__
 992
 993 $head NAME
 994
 995 $name - Snapshot of your installation at $now
 996
 997 $head SYNOPSIS
 998
 999 perl -MCPANPLUS -e "install $name"
1000
1001 $head CONTENTS
1002
1003 $string
1004
1005 $head CONFIGURATION
1006
1007 $perl_v
1008
1009 $head AUTHOR
1010
1011 This bundle has been generated autotomatically by
1012     $pkg $version
1013
1014 EOF
1015
1016     close $fh;
1017
1018     return $file;
1019 }
1020
1021 1;
1022
1023 =pod
1024
1025 =head1 BUG REPORTS
1026
1027 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1028
1029 =head1 AUTHOR
1030
1031 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1032
1033 =head1 COPYRIGHT
1034
1035 The CPAN++ interface (of which this module is a part of) is copyright (c)
1036 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1037
1038 This library is free software; you may redistribute and/or modify it
1039 under the same terms as Perl itself.
1040
1041 =head1 SEE ALSO
1042
1043 L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>
1044
1045 =cut
1046
1047 # Local variables:
1048 # c-indentation-style: bsd
1049 # c-basic-offset: 4
1050 # indent-tabs-mode: nil
1051 # End:
1052 # vim: expandtab shiftwidth=4:
1053
1054 __END__
1055
1056 todo:
1057 sub dist {          # not sure about this one -- probably already done
1058                       enough in Module.pm
1059 sub reports {       # in Module.pm, wrapper here
1060
1061