[Summary view] [Print] [Text view]

   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