ext/CPANPLUS/lib/CPANPLUS/Backend.pm

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