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         my $dist   = $mod = File::Basename::basename($dir);
 501         $dist     .= '-0'      unless $dist =~ /\-[0-9._]+$/;
 502         $dist     .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
 503
 504         my $modobj = CPANPLUS::Module::Fake->new(
 505                         module  => $mod,
 506                         version => 0,
 507                         package => $dist,
 508                         path    => $parent,
 509                         author  => CPANPLUS::Module::Author::Fake->new
 510                     );
 511
 512         ### better guess for the version
 513         $modobj->version( $modobj->package_version )
 514             if defined $modobj->package_version;
 515
 516         ### better guess at module name, if possible
 517         if ( my $pkgname = $modobj->package_name ) {
 518             $pkgname =~ s/-/::/g;
 519
 520             ### no sense replacing it unless we changed something
 521             $modobj->module( $pkgname )
 522                 if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
 523         }
 524
 525         $modobj->status->fetch( $parent );
 526         $modobj->status->extract( $dir );
 527         $modobj->get_installer_type;
 528         return $modobj;
 529     }
 530
 531     ### ok, so it looks like a distribution then?
 532     my @parts   = split '/', $mod;
 533     my $dist    = pop @parts;
 534
 535     ### ah, it's a URL
 536     if( $mod =~ m|\w+://.+| ) {
 537         my $modobj = CPANPLUS::Module::Fake->new(
 538                         module  => $dist,
 539                         version => 0,
 540                         package => $dist,
 541                         path    => File::Spec::Unix->catdir(
 542                                         $conf->_get_mirror('base'),
 543                                         UNKNOWN_DL_LOCATION ),
 544                         author  => CPANPLUS::Module::Author::Fake->new
 545                     );
 546
 547         ### set the fetch_from accessor so we know to by pass the
 548         ### usual mirrors
 549         $modobj->status->_fetch_from( $mod );
 550
 551         ### better guess for the version
 552         $modobj->version( $modobj->package_version )
 553             if defined $modobj->package_version;
 554
 555         ### better guess at module name, if possible
 556         if ( my $pkgname = $modobj->package_name ) {
 557             $pkgname =~ s/-/::/g;
 558
 559             ### no sense replacing it unless we changed something
 560             $modobj->module( $pkgname )
 561                 if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
 562         }
 563
 564         return $modobj;
 565     }
 566
 567     ### perhaps we can find it's a third party module?
 568     {   my $modobj = CPANPLUS::Module::Fake->new(
 569                         module  => $mod,
 570                         version => 0,
 571                         package => $dist,
 572                         path    => File::Spec::Unix->catdir(
 573                                         $conf->_get_mirror('base'),
 574                                         UNKNOWN_DL_LOCATION ),
 575                         author  => CPANPLUS::Module::Author::Fake->new
 576                     );
 577         if( $modobj->is_third_party ) {
 578             my $info = $modobj->third_party_information;
 579
 580             $modobj->author->author( $info->{author}     );
 581             $modobj->author->email(  $info->{author_url} );
 582             $modobj->description(    $info->{url} );
 583
 584             return $modobj;
 585         }
 586     }
 587
 588     unless( $dist ) {
 589         error( loc("%1 is not a proper distribution name!", $mod) );
 590         return;
 591     }
 592
 593     ### there's wonky uris out there, like this:
 594     ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091
 595     ### compensate for that
 596     my $author;
 597     ### you probably have an A/AB/ABC/....../Dist.tgz type uri
 598     if( (defined $parts[0] and length $parts[0] == 1) and
 599         (defined $parts[1] and length $parts[1] == 2) and
 600         $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i
 601     ) {
 602         splice @parts, 0, 2;    # remove the first 2 entries from the list
 603         $author = shift @parts; # this is the actual author name then
 604
 605     ### we''ll assume a ABC/..../Dist.tgz
 606     } else {
 607         $author = shift @parts || '';
 608     }
 609
 610     my($pkg, $version, $ext, $full) =
 611         $self->_split_package_string( package => $dist );
 612
 613     ### translate a distribution into a module name ###
 614     my $guess = $pkg;
 615     $guess =~ s/-/::/g if $guess;
 616
 617     my $maybe = $self->module_tree( $guess );
 618     if( IS_MODOBJ->( module => $maybe ) ) {
 619
 620         ### maybe you asked for a package instead
 621         if ( $maybe->package eq $mod ) {
 622             return $maybe;
 623
 624         ### perhaps an outdated version instead?
 625         } elsif ( $version ) {
 626             my $auth_obj; my $path;
 627
 628             ### did you give us an author part? ###
 629             if( $author ) {
 630                 $auth_obj   = CPANPLUS::Module::Author::Fake->new(
 631                                     _id     => $maybe->_id,
 632                                     cpanid  => uc $author,
 633                                     author  => uc $author,
 634                                 );
 635                 $path       = File::Spec::Unix->catdir(
 636                                     $conf->_get_mirror('base'),
 637                                     substr(uc $author, 0, 1),
 638                                     substr(uc $author, 0, 2),
 639                                     uc $author,
 640                                     @parts,     #possible sub dirs
 641                                 );
 642             } else {
 643                 $auth_obj   = $maybe->author;
 644                 $path       = $maybe->path;
 645             }
 646
 647             if( $maybe->package_name eq $pkg ) {
 648
 649                 my $modobj = CPANPLUS::Module::Fake->new(
 650                     module  => $maybe->module,
 651                     version => $version,
 652                     ### no extension? use the extension the original package
 653                     ### had instead
 654                     package => do { $ext
 655                                         ? $full
 656                                         : $full .'.'. $maybe->package_extension
 657                                 },
 658                     path    => $path,
 659                     author  => $auth_obj,
 660                     _id     => $maybe->_id
 661                 );
 662                 return $modobj;
 663
 664             ### you asked for a specific version?
 665             ### assume our $maybe is the one you wanted,
 666             ### and fix up the version..
 667             } else {
 668
 669                 my $modobj = $maybe->clone;
 670                 $modobj->version( $version );
 671                 $modobj->package(
 672                         $maybe->package_name .'-'.
 673                         $version .'.'.
 674                         $maybe->package_extension
 675                 );
 676
 677                 ### you wanted a specific author, but it's not the one
 678                 ### from the module tree? we'll fix it up
 679                 if( $author and $author ne $modobj->author->cpanid ) {
 680                     $modobj->author( $auth_obj );
 681                     $modobj->path( $path );
 682                 }
 683
 684                 return $modobj;
 685             }
 686
 687         ### you didn't care about a version, so just return the object then
 688         } elsif ( !$version ) {
 689             return $maybe;
 690         }
 691
 692     ### ok, so we can't find it, and it's not an outdated dist either
 693     ### perhaps we can fake one based on the author name and so on
 694     } elsif ( $author and $version ) {
 695
 696         ### be extra friendly and pad the .tar.gz suffix where needed
 697         ### it's just a guess of course, but most dists are .tar.gz
 698         $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
 699
 700         ### XXX duplication from above for generating author obj + path...
 701         my $modobj = CPANPLUS::Module::Fake->new(
 702             module  => $guess,
 703             version => $version,
 704             package => $dist,
 705             author  => CPANPLUS::Module::Author::Fake->new(
 706                             author  => uc $author,
 707                             cpanid  => uc $author,
 708                             _id     => $self->_id,
 709                         ),
 710             path    => File::Spec::Unix->catdir(
 711                             $conf->_get_mirror('base'),
 712                             substr(uc $author, 0, 1),
 713                             substr(uc $author, 0, 2),
 714                             uc $author,
 715                             @parts,         #possible subdirs
 716                         ),
 717             _id     => $self->_id,
 718         );
 719
 720         return $modobj;
 721
 722     ### face it, we have /no/ idea what he or she wants...
 723     ### let's start putting the blame somewhere
 724     } else {
 725
 726         unless( $author ) {
 727             error( loc( "'%1' does not contain an author part", $mod ) );
 728         }
 729
 730         error( loc( "Cannot find '%1' in the module tree", $mod ) );
 731     }
 732
 733     return;
 734 }
 735
 736 =pod
 737
 738 =head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] );
 739
 740 This method reloads the source files.
 741
 742 If C<update_source> is set to true, this will fetch new source files
 743 from your CPAN mirror. Otherwise, C<reload_indices> will do its
 744 usual cache checking and only update them if they are out of date.
 745
 746 By default, C<update_source> will be false.
 747
 748 The verbose setting defaults to what you have specified in your
 749 config file.
 750
 751 Returns true on success and false on failure.
 752
 753 =cut
 754
 755 sub reload_indices {
 756     my $self    = shift;
 757     my %hash    = @_;
 758     my $conf    = $self->configure_object;
 759
 760     my $tmpl = {
 761         update_source   => { default    => 0, allow => [qr/^\d$/] },
 762         verbose         => { default    => $conf->get_conf('verbose') },
 763     };
 764
 765     my $args = check( $tmpl, \%hash ) or return;
 766
 767     ### make a call to the internal _module_tree, so it triggers cache
 768     ### file age
 769     my $uptodate = $self->_check_trees( %$args );
 770
 771
 772     return 1 if $self->_build_trees(
 773                                 uptodate    => $uptodate,
 774                                 use_stored  => 0,
 775                                 verbose     => $conf->get_conf('verbose'),
 776                             );
 777
 778     error( loc( "Error rebuilding source trees!" ) );
 779
 780     return;
 781 }
 782
 783 =pod
 784
 785 =head2 $bool = $cb->flush(CACHE_NAME)
 786
 787 This method allows flushing of caches.
 788 There are several things which can be flushed:
 789
 790 =over 4
 791
 792 =item * C<methods>
 793
 794 The return status of methods which have been attempted, such as
 795 different ways of fetching files.  It is recommended that automatic
 796 flushing be used instead.
 797
 798 =item * C<hosts>
 799
 800 The return status of URIs which have been attempted, such as
 801 different hosts of fetching files.  It is recommended that automatic
 802 flushing be used instead.
 803
 804 =item * C<modules>
 805
 806 Information about modules such as prerequisites and whether
 807 installation succeeded, failed, or was not attempted.
 808
 809 =item * C<lib>
 810
 811 This resets PERL5LIB, which is changed to ensure that while installing
 812 modules they are in our @INC.
 813
 814 =item * C<load>
 815
 816 This resets the cache of modules we've attempted to load, but failed.
 817 This enables you to load them again after a failed load, if they
 818 somehow have become available.
 819
 820 =item * C<all>
 821
 822 Flush all of the aforementioned caches.
 823
 824 =back
 825
 826 Returns true on success and false on failure.
 827
 828 =cut
 829
 830 sub flush {
 831     my $self = shift;
 832     my $type = shift or return;
 833
 834     my $cache = {
 835         methods => [ qw( methods load ) ],
 836         hosts   => [ qw( hosts ) ],
 837         modules => [ qw( modules lib) ],
 838         lib     => [ qw( lib ) ],
 839         load    => [ qw( load ) ],
 840         all     => [ qw( hosts lib modules methods load ) ],
 841     };
 842
 843     my $aref = $cache->{$type}
 844                     or (
 845                         error( loc("No such cache '%1'", $type) ),
 846                         return
 847                     );
 848
 849     return $self->_flush( list => $aref );
 850 }
 851
 852 =pod
 853
 854 =head2 @mods = $cb->installed()
 855
 856 Returns a list of module objects of all your installed modules.
 857 If an error occurs, it will return false.
 858
 859 See L<CPANPLUS::Module> for the operations you can perform on a
 860 module object.
 861
 862 =cut
 863
 864 sub installed {
 865     my $self = shift;
 866     my $aref = $self->_all_installed;
 867
 868     return @$aref if $aref;
 869     return;
 870 }
 871
 872 =pod
 873
 874 =head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] )
 875
 876 Creates a local mirror of CPAN, of only the most recent sources in a
 877 location you specify. If you set this location equal to a custom host
 878 in your C<CPANPLUS::Config> you can use your local mirror to install
 879 from.
 880
 881 It takes the following arguments:
 882
 883 =over 4
 884
 885 =item path
 886
 887 The location where to create the local mirror.
 888
 889 =item index_files
 890
 891 Enable/disable fetching of index files. You can disable fetching of the
 892 index files if you don't plan to use the local mirror as your primary
 893 site, or if you'd like up-to-date index files be fetched from elsewhere.
 894
 895 Defaults to true.
 896
 897 =item force
 898
 899 Forces refetching of packages, even if they are there already.
 900
 901 Defaults to whatever setting you have in your C<CPANPLUS::Config>.
 902
 903 =item verbose
 904
 905 Prints more messages about what its doing.
 906
 907 Defaults to whatever setting you have in your C<CPANPLUS::Config>.
 908
 909 =back
 910
 911 Returns true on success and false on error.
 912
 913 =cut
 914
 915 sub local_mirror {
 916     my $self = shift;
 917     my $conf = $self->configure_object;
 918     my %hash = @_;
 919
 920     my($path, $index, $force, $verbose);
 921     my $tmpl = {
 922         path        => { default => $conf->get_conf('base'),
 923                             store => \$path },
 924         index_files => { default => 1, store => \$index },
 925         force       => { default => $conf->get_conf('force'),
 926                             store => \$force },
 927         verbose     => { default => $conf->get_conf('verbose'),
 928                             store => \$verbose },
 929     };
 930
 931     check( $tmpl, \%hash ) or return;
 932
 933     unless( -d $path ) {
 934         $self->_mkdir( dir => $path )
 935                 or( error( loc( "Could not create '%1', giving up", $path ) ),
 936                     return
 937                 );
 938     } elsif ( ! -w _ ) {
 939         error( loc( "Could not write to '%1', giving up", $path ) );
 940         return;
 941     }
 942
 943     my $flag;
 944     AUTHOR: {
 945     for my $auth (  sort { $a->cpanid cmp $b->cpanid }
 946                     values %{$self->author_tree}
 947     ) {
 948
 949         MODULE: {
 950         my $i;
 951         for my $mod ( $auth->modules ) {
 952             my $fetchdir = File::Spec->catdir( $path, $mod->path );
 953
 954             my %opts = (
 955                 verbose     => $verbose,
 956                 force       => $force,
 957                 fetchdir    => $fetchdir,
 958             );
 959
 960             ### only do this the for the first module ###
 961             unless( $i++ ) {
 962                 $mod->_get_checksums_file(
 963                             %opts
 964                         ) or (
 965                             error( loc( "Could not fetch %1 file, " .
 966                                         "skipping author '%2'",
 967                                         CHECKSUMS, $auth->cpanid ) ),
 968                             $flag++, next AUTHOR
 969                         );
 970             }
 971
 972             $mod->fetch( %opts )
 973                     or( error( loc( "Could not fetch '%1'", $mod->module ) ),
 974                         $flag++, next MODULE
 975                     );
 976         } }
 977     } }
 978
 979     if( $index ) {
 980         for my $name (qw[auth dslip mod]) {
 981             $self->_update_source(
 982                         name    => $name,
 983                         verbose => $verbose,
 984                         path    => $path,
 985                     ) or ( $flag++, next );
 986         }
 987     }
 988
 989     return !$flag;
 990 }
 991
 992 =pod
 993
 994 =head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL])
 995
 996 Writes out a snapshot of your current installation in C<CPAN> bundle
 997 style. This can then be used to install the same modules for a
 998 different or on a different machine by issuing the following commands:
 999
1000     ### using the default shell:
1001     CPAN Terminal> i file://path/to/Snapshot_XXYY.pm
1002
1003     ### using the API
1004     $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' );
1005     $modobj->install;
1006
1007 It will, by default, write to an 'autobundle' directory under your
1008 cpanplus homedirectory, but you can override that by supplying a
1009 C<path> argument.
1010
1011 It will return the location of the output file on success and false on
1012 failure.
1013
1014 =cut
1015
1016 sub autobundle {
1017     my $self = shift;
1018     my $conf = $self->configure_object;
1019     my %hash = @_;
1020
1021     my($path,$force,$verbose);
1022     my $tmpl = {
1023         force   => { default => $conf->get_conf('force'), store => \$force },
1024         verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
1025         path    => { default => File::Spec->catdir(
1026                                         $conf->get_conf('base'),
1027                                         $self->_perl_version( perl => $^X ),
1028                                         $conf->_get_build('distdir'),
1029                                         $conf->_get_build('autobundle') ),
1030                     store => \$path },
1031     };
1032
1033     check($tmpl, \%hash) or return;
1034
1035     unless( -d $path ) {
1036         $self->_mkdir( dir => $path )
1037                 or( error(loc("Could not create directory '%1'", $path ) ),
1038                     return
1039                 );
1040     }
1041
1042     my $name; my $file;
1043     {   ### default filename for the bundle ###
1044         my($year,$month,$day) = (localtime)[5,4,3];
1045         $year += 1900; $month++;
1046
1047         my $ext = 0;
1048
1049         my $prefix  = $conf->_get_build('autobundle_prefix');
1050         my $format  = "${prefix}_%04d_%02d_%02d_%02d";
1051
1052         BLOCK: {
1053             $name = sprintf( $format, $year, $month, $day, $ext);
1054
1055             $file = File::Spec->catfile( $path, $name . '.pm' );
1056
1057             -f $file ? ++$ext && redo BLOCK : last BLOCK;
1058         }
1059     }
1060     my $fh;
1061     unless( $fh = FileHandle->new( ">$file" ) ) {
1062         error( loc( "Could not open '%1' for writing: %2", $file, $! ) );
1063         return;
1064     }
1065
1066     ### make sure we load the module tree *before* doing this, as it
1067     ### starts to chdir all over the place
1068     $self->module_tree;
1069
1070     my $string = join "\n\n",
1071                     map {
1072                         join ' ',
1073                             $_->module,
1074                             ($_->installed_version(verbose => 0) || 'undef')
1075                     } sort {
1076                         $a->module cmp $b->module
1077                     }  $self->installed;
1078
1079     my $now     = scalar localtime;
1080     my $head    = '=head1';
1081     my $pkg     = __PACKAGE__;
1082     my $version = $self->VERSION;
1083     my $perl_v  = join '', `$^X -V`;
1084
1085     print $fh <<EOF;
1086 package $name;
1087
1088 \$VERSION = '0.01';
1089
1090 1;
1091
1092 __END__
1093
1094 $head NAME
1095
1096 $name - Snapshot of your installation at $now
1097
1098 $head SYNOPSIS
1099
1100 perl -MCPANPLUS -e "install file://full/path/to/$name"
1101
1102 $head CONTENTS
1103
1104 $string
1105
1106 $head CONFIGURATION
1107
1108 $perl_v
1109
1110 $head AUTHOR
1111
1112 This bundle has been generated autotomatically by
1113     $pkg $version
1114
1115 EOF
1116
1117     close $fh;
1118
1119     return $file;
1120 }
1121
1122 =head2 $bool = $cb->save_state
1123
1124 Explicit command to save memory state to disk. This can be used to save
1125 information to disk about where a module was extracted, the result of
1126 C<make test>, etc. This will then be re-loaded into memory when a new
1127 session starts.
1128
1129 The capability of saving state to disk depends on the source engine
1130 being used (See C<CPANPLUS::Config> for the option to choose your
1131 source engine). The default storage engine supports this option.
1132
1133 Most users will not need this command, but it can handy for automated
1134 systems like setting up CPAN smoke testers.
1135
1136 The method will return true if it managed to save the state to disk,
1137 or false if it did not.
1138
1139 =cut
1140
1141 sub save_state {
1142     my $self = shift;
1143     return $self->_save_state( @_ );
1144 }
1145
1146
1147 ### XXX these wrappers are not individually tested! only the underlying
1148 ### code through source.t and indirectly trought he CustomSource plugin.
1149 =pod
1150
1151 =head1 CUSTOM MODULE SOURCES
1152
1153 Besides the sources as provided by the general C<CPAN> mirrors, it's
1154 possible to add your own sources list to your C<CPANPLUS> index.
1155
1156 The methodology behind this works much like C<Debian's apt-sources>.
1157
1158 The methods below show you how to make use of this functionality. Also
1159 note that most of these methods are available through the default shell
1160 plugin command C</cs>, making them available as shortcuts through the
1161 shell and via the commandline.
1162
1163 =head2 %files = $cb->list_custom_sources
1164
1165 Returns a mapping of registered custom sources and their local indices
1166 as follows:
1167
1168     /full/path/to/local/index => http://remote/source
1169
1170 Note that any file starting with an C<#> is being ignored.
1171
1172 =cut
1173
1174 sub list_custom_sources {
1175     return shift->__list_custom_module_sources( @_ );
1176 }
1177
1178 =head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] );
1179
1180 Adds an C<URI> to your own sources list and mirrors its index. See the
1181 documentation on C<< $cb->update_custom_source >> on how this is done.
1182
1183 Returns the full path to the local index on success, or false on failure.
1184
1185 Note that when adding a new C<URI>, the change to the in-memory tree is
1186 not saved until you rebuild or save the tree to disk again. You can do
1187 this using the C<< $cb->reload_indices >> method.
1188
1189 =cut
1190
1191 sub add_custom_source {
1192     return shift->_add_custom_module_source( @_ );
1193 }
1194
1195 =head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] );
1196
1197 Removes an C<URI> from your own sources list and removes its index.
1198
1199 To find out what C<URI>s you have as part of your own sources list, use
1200 the C<< $cb->list_custom_sources >> method.
1201
1202 Returns the full path to the deleted local index file on success, or false
1203 on failure.
1204
1205 =cut
1206
1207 ### XXX do clever dispatching based on arg number?
1208 sub remove_custom_source {
1209     return shift->_remove_custom_module_source( @_ );
1210 }
1211
1212 =head2 $bool = $cb->update_custom_source( [remote => URI] );
1213
1214 Updates the indexes for all your custom sources. It does this by fetching
1215 a file called C<packages.txt> in the root of the custom sources's C<URI>.
1216 If you provide the C<remote> argument, it will only update the index for
1217 that specific C<URI>.
1218
1219 Here's an example of how custom sources would resolve into index files:
1220
1221   file:///path/to/sources       =>  file:///path/to/sources/packages.txt
1222   http://example.com/sources    =>  http://example.com/sources/packages.txt
1223   ftp://example.com/sources     =>  ftp://example.com/sources/packages.txt
1224
1225 The file C<packages.txt> simply holds a list of packages that can be found
1226 under the root of the C<URI>. This file can be automatically generated for
1227 you when the remote source is a C<file:// URI>. For C<http://>, C<ftp://>,
1228 and similar, the administrator of that repository should run the method
1229 C<< $cb->write_custom_source_index >> on the repository to allow remote
1230 users to index it.
1231
1232 For details, see the C<< $cb->write_custom_source_index >> method below.
1233
1234 All packages that are added via this mechanism will be attributed to the
1235 author with C<CPANID> C<LOCAL>. You can use this id to search for all
1236 added packages.
1237
1238 =cut
1239
1240 sub update_custom_source {
1241     my $self = shift;
1242
1243     ### if it mentions /remote/, the request is to update a single uri,
1244     ### not all the ones we have, so dispatch appropriately
1245     my $rv = grep( /remote/i, @_)
1246         ? $self->__update_custom_module_source( @_ )
1247         : $self->__update_custom_module_sources( @_ );
1248
1249     return $rv;
1250 }
1251
1252 =head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] );
1253
1254 Writes the index for a custom repository root. Most users will not have to
1255 worry about this, but administrators of a repository will need to make sure
1256 their indexes are up to date.
1257
1258 The index will be written to a file called C<packages.txt> in your repository
1259 root, which you can specify with the C<path> argument. You can override this
1260 location by specifying the C<to> argument, but in normal operation, that should
1261 not be required.
1262
1263 Once the index file is written, users can then add the C<URI> pointing to
1264 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.
1265
1266 =cut
1267
1268 sub write_custom_source_index {
1269     return shift->__write_custom_module_index( @_ );
1270 }
1271
1272 1;
1273
1274 =pod
1275
1276 =head1 BUG REPORTS
1277
1278 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1279
1280 =head1 AUTHOR
1281
1282 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1283
1284 =head1 COPYRIGHT
1285
1286 The CPAN++ interface (of which this module is a part of) is copyright (c)
1287 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1288
1289 This library is free software; you may redistribute and/or modify it
1290 under the same terms as Perl itself.
1291
1292 =head1 SEE ALSO
1293
1294 L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>,
1295 L<CPANPLUS::Selfupdate>
1296
1297 =cut
1298
1299 # Local variables:
1300 # c-indentation-style: bsd
1301 # c-basic-offset: 4
1302 # indent-tabs-mode: nil
1303 # End:
1304 # vim: expandtab shiftwidth=4:
1305
1306 __END__
1307
1308 todo:
1309 sub dist {          # not sure about this one -- probably already done
1310                       enough in Module.pm
1311 sub reports {       # in Module.pm, wrapper here
1312
1313