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