summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm1330
1 files changed, 1330 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm
new file mode 100644
index 00000000000..a599e5429eb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm
@@ -0,0 +1,1330 @@
+package CPANPLUS::Backend;
+
+use strict;
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Configure;
+use CPANPLUS::Internals;
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Module;
+use CPANPLUS::Module::Author;
+use CPANPLUS::Backend::RV;
+
+use FileHandle;
+use File::Spec ();
+use File::Spec::Unix ();
+use File::Basename ();
+use Params::Check qw[check];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+$Params::Check::VERBOSE = 1;
+
+use vars qw[@ISA $VERSION];
+
+@ISA = qw[CPANPLUS::Internals];
+$VERSION = $CPANPLUS::Internals::VERSION;
+
+### mark that we're running under CPANPLUS to spawned processes
+$ENV{'PERL5_CPANPLUS_IS_RUNNING'} = $$;
+
+### XXX version.pm MAY format this version, if it's in use... :(
+### so for consistency, just call ->VERSION ourselves as well.
+$ENV{'PERL5_CPANPLUS_IS_VERSION'} = __PACKAGE__->VERSION;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Backend
+
+=head1 SYNOPSIS
+
+ my $cb = CPANPLUS::Backend->new;
+ my $conf = $cb->configure_object;
+
+ my $author = $cb->author_tree('KANE');
+ my $mod = $cb->module_tree('Some::Module');
+ my $mod = $cb->parse_module( module => 'Some::Module' );
+
+ my @objs = $cb->search( type => TYPE,
+ allow => [...] );
+
+ $cb->flush('all');
+ $cb->reload_indices;
+ $cb->local_mirror;
+
+
+=head1 DESCRIPTION
+
+This module provides the programmer's interface to the C<CPANPLUS>
+libraries.
+
+=head1 ENVIRONMENT
+
+When C<CPANPLUS::Backend> is loaded, which is necessary for just
+about every <CPANPLUS> operation, the environment variable
+C<PERL5_CPANPLUS_IS_RUNNING> is set to the current process id.
+
+Additionally, the environment variable C<PERL5_CPANPLUS_IS_VERSION>
+will be set to the version of C<CPANPLUS::Backend>.
+
+This information might be useful somehow to spawned processes.
+
+=head1 METHODS
+
+=head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] )
+
+This method returns a new C<CPANPLUS::Backend> object.
+This also initialises the config corresponding to this object.
+You have two choices in this:
+
+=over 4
+
+=item Provide a valid C<CPANPLUS::Configure> object
+
+This will be used verbatim.
+
+=item No arguments
+
+Your default config will be loaded and used.
+
+=back
+
+New will return a C<CPANPLUS::Backend> object on success and die on
+failure.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $conf;
+
+ if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) {
+ $conf = shift;
+ } else {
+ $conf = CPANPLUS::Configure->new() or return;
+ }
+
+ my $self = $class->SUPER::_init( _conf => $conf );
+
+ return $self;
+}
+
+=pod
+
+=head2 $href = $cb->module_tree( [@modules_names_list] )
+
+Returns a reference to the CPANPLUS module tree.
+
+If you give it any arguments, they will be treated as module names
+and C<module_tree> will try to look up these module names and
+return the corresponding module objects instead.
+
+See L<CPANPLUS::Module> for the operations you can perform on a
+module object.
+
+=cut
+
+sub module_tree {
+ my $self = shift;
+ my $modtree = $self->_module_tree;
+
+ if( @_ ) {
+ my @rv;
+ for my $name ( grep { defined } @_) {
+
+ ### From John Malmberg: This is failing on VMS
+ ### because ODS-2 does not retain the case of
+ ### filenames that are created.
+ ### The problem is the filename is being converted
+ ### to a module name and then looked up in the
+ ### %$modtree hash.
+ ###
+ ### As a fix, we do a search on VMS instead --
+ ### more cpu cycles, but it gets around the case
+ ### problem --kane
+ my ($modobj) = do {
+ ON_VMS
+ ? $self->search(
+ type => 'module',
+ allow => [qr/^$name$/i],
+ )
+ : $modtree->{$name}
+ };
+
+ push @rv, $modobj || '';
+ }
+ return @rv == 1 ? $rv[0] : @rv;
+ } else {
+ return $modtree;
+ }
+}
+
+=pod
+
+=head2 $href = $cb->author_tree( [@author_names_list] )
+
+Returns a reference to the CPANPLUS author tree.
+
+If you give it any arguments, they will be treated as author names
+and C<author_tree> will try to look up these author names and
+return the corresponding author objects instead.
+
+See L<CPANPLUS::Module::Author> for the operations you can perform on
+an author object.
+
+=cut
+
+sub author_tree {
+ my $self = shift;
+ my $authtree = $self->_author_tree;
+
+ if( @_ ) {
+ my @rv;
+ for my $name (@_) {
+ push @rv, $authtree->{$name} || '';
+ }
+ return @rv == 1 ? $rv[0] : @rv;
+ } else {
+ return $authtree;
+ }
+}
+
+=pod
+
+=head2 $conf = $cb->configure_object;
+
+Returns a copy of the C<CPANPLUS::Configure> object.
+
+See L<CPANPLUS::Configure> for operations you can perform on a
+configure object.
+
+=cut
+
+sub configure_object { return shift->_conf() };
+
+=head2 $su = $cb->selfupdate_object;
+
+Returns a copy of the C<CPANPLUS::Selfupdate> object.
+
+See the L<CPANPLUS::Selfupdate> manpage for the operations
+you can perform on the selfupdate object.
+
+=cut
+
+sub selfupdate_object { return shift->_selfupdate() };
+
+=pod
+
+=head2 @mods = $cb->search( type => TYPE, allow => AREF, [data => AREF, verbose => BOOL] )
+
+C<search> enables you to search for either module or author objects,
+based on their data. The C<type> you can specify is any of the
+accessors specified in C<CPANPLUS::Module::Author> or
+C<CPANPLUS::Module>. C<search> will determine by the C<type> you
+specified whether to search by author object or module object.
+
+You have to specify an array reference of regular expressions or
+strings to match against. The rules used for this array ref are the
+same as in C<Params::Check>, so read that manpage for details.
+
+The search is an C<or> search, meaning that if C<any> of the criteria
+match, the search is considered to be successful.
+
+You can specify the result of a previous search as C<data> to limit
+the new search to these module or author objects, rather than the
+entire module or author tree. This is how you do C<and> searches.
+
+Returns a list of module or author objects on success and false
+on failure.
+
+See L<CPANPLUS::Module> for the operations you can perform on a
+module object.
+See L<CPANPLUS::Module::Author> for the operations you can perform on
+an author object.
+
+=cut
+
+sub search {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my ($type);
+ my $args = do {
+ local $Params::Check::NO_DUPLICATES = 0;
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ type => { required => 1, allow => [CPANPLUS::Module->accessors(),
+ CPANPLUS::Module::Author->accessors()], store => \$type },
+ allow => { required => 1, default => [ ], strict_type => 1 },
+ };
+
+ check( $tmpl, \%hash )
+ } or return;
+
+ ### figure out whether it was an author or a module search
+ ### when ambiguous, it'll be an author search.
+ my $aref;
+ if( grep { $type eq $_ } CPANPLUS::Module::Author->accessors() ) {
+ $aref = $self->_search_author_tree( %$args );
+ } else {
+ $aref = $self->_search_module_tree( %$args );
+ }
+
+ return @$aref if $aref;
+ return;
+}
+
+=pod
+
+=head2 $backend_rv = $cb->fetch( modules => \@mods )
+
+Fetches a list of modules. C<@mods> can be a list of distribution
+names, module names or module objects--basically anything that
+L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=head2 $backend_rv = $cb->extract( modules => \@mods )
+
+Extracts a list of modules. C<@mods> can be a list of distribution
+names, module names or module objects--basically anything that
+L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=head2 $backend_rv = $cb->install( modules => \@mods )
+
+Installs a list of modules. C<@mods> can be a list of distribution
+names, module names or module objects--basically anything that
+L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=head2 $backend_rv = $cb->readme( modules => \@mods )
+
+Fetches the readme for a list of modules. C<@mods> can be a list of
+distribution names, module names or module objects--basically
+anything that L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=head2 $backend_rv = $cb->files( modules => \@mods )
+
+Returns a list of files used by these modules if they are installed.
+C<@mods> can be a list of distribution names, module names or module
+objects--basically anything that L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=head2 $backend_rv = $cb->distributions( modules => \@mods )
+
+Returns a list of module objects representing all releases for this
+module on success.
+C<@mods> can be a list of distribution names, module names or module
+objects, basically anything that L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=cut
+
+### XXX add direcotry_tree, packlist etc? or maybe remove files? ###
+for my $func (qw[fetch extract install readme files distributions]) {
+ no strict 'refs';
+
+ *$func = sub {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my ($mods);
+ my $args = do {
+ local $Params::Check::NO_DUPLICATES = 1;
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ modules => { default => [], strict_type => 1,
+ required => 1, store => \$mods },
+ };
+
+ check( $tmpl, \%hash );
+ } or return;
+
+ ### make them all into module objects ###
+ my %mods = map { $_ => $self->parse_module(module => $_) || '' } @$mods;
+
+ my $flag; my $href;
+ while( my($name,$obj) = each %mods ) {
+ $href->{$name} = IS_MODOBJ->( mod => $obj )
+ ? $obj->$func( %$args )
+ : undef;
+
+ $flag++ unless $href->{$name};
+ }
+
+ return CPANPLUS::Backend::RV->new(
+ function => $func,
+ ok => !$flag,
+ rv => $href,
+ args => \%hash,
+ );
+ }
+}
+
+=pod
+
+=head2 $mod_obj = $cb->parse_module( module => $modname|$distname|$modobj|URI|PATH )
+
+C<parse_module> tries to find a C<CPANPLUS::Module> object that
+matches your query. Here's a list of examples you could give to
+C<parse_module>;
+
+=over 4
+
+=item Text::Bastardize
+
+=item Text-Bastardize
+
+=item Text-Bastardize-1.06
+
+=item AYRNIEU/Text-Bastardize
+
+=item AYRNIEU/Text-Bastardize-1.06
+
+=item AYRNIEU/Text-Bastardize-1.06.tar.gz
+
+=item http://example.com/Text-Bastardize-1.06.tar.gz
+
+=item file:///tmp/Text-Bastardize-1.06.tar.gz
+
+=item /tmp/Text-Bastardize-1.06
+
+=item ./Text-Bastardize-1.06
+
+=item .
+
+=back
+
+These items would all come up with a C<CPANPLUS::Module> object for
+C<Text::Bastardize>. The ones marked explicitly as being version 1.06
+would give back a C<CPANPLUS::Module> object of that version.
+Even if the version on CPAN is currently higher.
+
+The last three are examples of PATH resolution. In the first, we supply
+an absolute path to the unwrapped distribution. In the second the
+distribution is relative to the current working directory.
+In the third, we will use the current working directory.
+
+If C<parse_module> is unable to actually find the module you are looking
+for in its module tree, but you supplied it with an author, module
+and version part in a distribution name or URI, it will create a fake
+C<CPANPLUS::Module> object for you, that you can use just like the
+real thing.
+
+See L<CPANPLUS::Module> for the operations you can perform on a
+module object.
+
+If even this fancy guessing doesn't enable C<parse_module> to create
+a fake module object for you to use, it will warn about an error and
+return false.
+
+=cut
+
+sub parse_module {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my $mod;
+ my $tmpl = {
+ module => { required => 1, store => \$mod },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ return $mod if IS_MODOBJ->( module => $mod );
+
+ ### ok, so it's not a module object, but a ref nonetheless?
+ ### what are you smoking?
+ if( ref $mod ) {
+ error(loc("Can not parse module string from reference '%1'", $mod ));
+ return;
+ }
+
+ ### check only for allowed characters in a module name
+ unless( $mod =~ /[^\w:]/ ) {
+
+ ### perhaps we can find it in the module tree?
+ my $maybe = $self->module_tree($mod);
+ return $maybe if IS_MODOBJ->( module => $maybe );
+ }
+
+ ### Special case arbitary file paths such as '.' etc.
+ if ( $mod and -d File::Spec->rel2abs($mod) ) {
+ my $dir = File::Spec->rel2abs($mod);
+ my $parent = File::Spec->rel2abs( File::Spec->catdir( $dir, '..' ) );
+
+ ### fix paths on VMS
+ if (ON_VMS) {
+ $dir = VMS::Filespec::unixify($dir);
+ $parent = VMS::Filespec::unixify($parent);
+ }
+
+ my $dist = $mod = File::Basename::basename($dir);
+ $dist .= '-0' unless $dist =~ /\-[0-9._]+$/;
+ $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
+
+ my $modobj = CPANPLUS::Module::Fake->new(
+ module => $mod,
+ version => 0,
+ package => $dist,
+ path => $parent,
+ author => CPANPLUS::Module::Author::Fake->new
+ );
+
+ ### better guess for the version
+ $modobj->version( $modobj->package_version )
+ if defined $modobj->package_version;
+
+ ### better guess at module name, if possible
+ if ( my $pkgname = $modobj->package_name ) {
+ $pkgname =~ s/-/::/g;
+
+ ### no sense replacing it unless we changed something
+ $modobj->module( $pkgname )
+ if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
+ }
+
+ $modobj->status->fetch( $parent );
+ $modobj->status->extract( $dir );
+ $modobj->get_installer_type;
+ return $modobj;
+ }
+
+ ### ok, so it looks like a distribution then?
+ my @parts = split '/', $mod;
+ my $dist = pop @parts;
+
+ ### ah, it's a URL
+ if( $mod =~ m|\w+://.+| ) {
+ my $modobj = CPANPLUS::Module::Fake->new(
+ module => $dist,
+ version => 0,
+ package => $dist,
+ path => File::Spec::Unix->catdir(
+ $conf->_get_mirror('base'),
+ UNKNOWN_DL_LOCATION ),
+ author => CPANPLUS::Module::Author::Fake->new
+ );
+
+ ### set the fetch_from accessor so we know to by pass the
+ ### usual mirrors
+ $modobj->status->_fetch_from( $mod );
+
+ ### better guess for the version
+ $modobj->version( $modobj->package_version )
+ if defined $modobj->package_version;
+
+ ### better guess at module name, if possible
+ if ( my $pkgname = $modobj->package_name ) {
+ $pkgname =~ s/-/::/g;
+
+ ### no sense replacing it unless we changed something
+ $modobj->module( $pkgname )
+ if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
+ }
+
+ return $modobj;
+ }
+
+ ### perhaps we can find it's a third party module?
+ { my $modobj = CPANPLUS::Module::Fake->new(
+ module => $mod,
+ version => 0,
+ package => $dist,
+ path => File::Spec::Unix->catdir(
+ $conf->_get_mirror('base'),
+ UNKNOWN_DL_LOCATION ),
+ author => CPANPLUS::Module::Author::Fake->new
+ );
+ if( $modobj->is_third_party ) {
+ my $info = $modobj->third_party_information;
+
+ $modobj->author->author( $info->{author} );
+ $modobj->author->email( $info->{author_url} );
+ $modobj->description( $info->{url} );
+
+ return $modobj;
+ }
+ }
+
+ unless( $dist ) {
+ error( loc("%1 is not a proper distribution name!", $mod) );
+ return;
+ }
+
+ ### there's wonky uris out there, like this:
+ ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091
+ ### compensate for that
+ my $author;
+ ### you probably have an A/AB/ABC/....../Dist.tgz type uri
+ if( (defined $parts[0] and length $parts[0] == 1) and
+ (defined $parts[1] and length $parts[1] == 2) and
+ $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i
+ ) {
+ splice @parts, 0, 2; # remove the first 2 entries from the list
+ $author = shift @parts; # this is the actual author name then
+
+ ### we''ll assume a ABC/..../Dist.tgz
+ } else {
+ $author = shift @parts || '';
+ }
+
+ my($pkg, $version, $ext, $full) =
+ $self->_split_package_string( package => $dist );
+
+ ### translate a distribution into a module name ###
+ my $guess = $pkg;
+ $guess =~ s/-/::/g if $guess;
+
+ my $maybe = $self->module_tree( $guess );
+ if( IS_MODOBJ->( module => $maybe ) ) {
+
+ ### maybe you asked for a package instead
+ if ( $maybe->package eq $mod ) {
+ return $maybe;
+
+ ### perhaps an outdated version instead?
+ } elsif ( $version ) {
+ my $auth_obj; my $path;
+
+ ### did you give us an author part? ###
+ if( $author ) {
+ $auth_obj = CPANPLUS::Module::Author::Fake->new(
+ _id => $maybe->_id,
+ cpanid => uc $author,
+ author => uc $author,
+ );
+ $path = File::Spec::Unix->catdir(
+ $conf->_get_mirror('base'),
+ substr(uc $author, 0, 1),
+ substr(uc $author, 0, 2),
+ uc $author,
+ @parts, #possible sub dirs
+ );
+ } else {
+ $auth_obj = $maybe->author;
+ $path = $maybe->path;
+ }
+
+ if( $maybe->package_name eq $pkg ) {
+
+ my $modobj = CPANPLUS::Module::Fake->new(
+ module => $maybe->module,
+ version => $version,
+ ### no extension? use the extension the original package
+ ### had instead
+ package => do { $ext
+ ? $full
+ : $full .'.'. $maybe->package_extension
+ },
+ path => $path,
+ author => $auth_obj,
+ _id => $maybe->_id
+ );
+ return $modobj;
+
+ ### you asked for a specific version?
+ ### assume our $maybe is the one you wanted,
+ ### and fix up the version..
+ } else {
+
+ my $modobj = $maybe->clone;
+ $modobj->version( $version );
+ $modobj->package(
+ $maybe->package_name .'-'.
+ $version .'.'.
+ $maybe->package_extension
+ );
+
+ ### you wanted a specific author, but it's not the one
+ ### from the module tree? we'll fix it up
+ if( $author and $author ne $modobj->author->cpanid ) {
+ $modobj->author( $auth_obj );
+ $modobj->path( $path );
+ }
+
+ return $modobj;
+ }
+
+ ### you didn't care about a version, so just return the object then
+ } elsif ( !$version ) {
+ return $maybe;
+ }
+
+ ### ok, so we can't find it, and it's not an outdated dist either
+ ### perhaps we can fake one based on the author name and so on
+ } elsif ( $author and $version ) {
+
+ ### be extra friendly and pad the .tar.gz suffix where needed
+ ### it's just a guess of course, but most dists are .tar.gz
+ $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
+
+ ### XXX duplication from above for generating author obj + path...
+ my $modobj = CPANPLUS::Module::Fake->new(
+ module => $guess,
+ version => $version,
+ package => $dist,
+ author => CPANPLUS::Module::Author::Fake->new(
+ author => uc $author,
+ cpanid => uc $author,
+ _id => $self->_id,
+ ),
+ path => File::Spec::Unix->catdir(
+ $conf->_get_mirror('base'),
+ substr(uc $author, 0, 1),
+ substr(uc $author, 0, 2),
+ uc $author,
+ @parts, #possible subdirs
+ ),
+ _id => $self->_id,
+ );
+
+ return $modobj;
+
+ ### face it, we have /no/ idea what he or she wants...
+ ### let's start putting the blame somewhere
+ } else {
+
+ # Lets not give up too easily. There is one last chance
+ # http://perlmonks.org/?node_id=805957
+ # This should catch edge-cases where the package name
+ # is unrelated to the modules it contains.
+
+ my ($modobj) = grep { $_->package_name eq $mod }
+ $self->search( type => 'package', allow => [ qr/^\Q$mod\E/ ], );
+ return $modobj if IS_MODOBJ->( module => $modobj );
+
+ unless( $author ) {
+ error( loc( "'%1' does not contain an author part", $mod ) );
+ }
+
+ error( loc( "Cannot find '%1' in the module tree", $mod ) );
+ }
+
+ return;
+}
+
+=pod
+
+=head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] );
+
+This method reloads the source files.
+
+If C<update_source> is set to true, this will fetch new source files
+from your CPAN mirror. Otherwise, C<reload_indices> will do its
+usual cache checking and only update them if they are out of date.
+
+By default, C<update_source> will be false.
+
+The verbose setting defaults to what you have specified in your
+config file.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub reload_indices {
+ my $self = shift;
+ my %hash = @_;
+ my $conf = $self->configure_object;
+
+ my $tmpl = {
+ update_source => { default => 0, allow => [qr/^\d$/] },
+ verbose => { default => $conf->get_conf('verbose') },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ ### make a call to the internal _module_tree, so it triggers cache
+ ### file age
+ my $uptodate = $self->_check_trees( %$args );
+
+
+ return 1 if $self->_build_trees(
+ uptodate => $uptodate,
+ use_stored => 0,
+ verbose => $conf->get_conf('verbose'),
+ );
+
+ error( loc( "Error rebuilding source trees!" ) );
+
+ return;
+}
+
+=pod
+
+=head2 $bool = $cb->flush(CACHE_NAME)
+
+This method allows flushing of caches.
+There are several things which can be flushed:
+
+=over 4
+
+=item * C<methods>
+
+The return status of methods which have been attempted, such as
+different ways of fetching files. It is recommended that automatic
+flushing be used instead.
+
+=item * C<hosts>
+
+The return status of URIs which have been attempted, such as
+different hosts of fetching files. It is recommended that automatic
+flushing be used instead.
+
+=item * C<modules>
+
+Information about modules such as prerequisites and whether
+installation succeeded, failed, or was not attempted.
+
+=item * C<lib>
+
+This resets PERL5LIB, which is changed to ensure that while installing
+modules they are in our @INC.
+
+=item * C<load>
+
+This resets the cache of modules we've attempted to load, but failed.
+This enables you to load them again after a failed load, if they
+somehow have become available.
+
+=item * C<all>
+
+Flush all of the aforementioned caches.
+
+=back
+
+Returns true on success and false on failure.
+
+=cut
+
+sub flush {
+ my $self = shift;
+ my $type = shift or return;
+
+ my $cache = {
+ methods => [ qw( methods load ) ],
+ hosts => [ qw( hosts ) ],
+ modules => [ qw( modules lib) ],
+ lib => [ qw( lib ) ],
+ load => [ qw( load ) ],
+ all => [ qw( hosts lib modules methods load ) ],
+ };
+
+ my $aref = $cache->{$type}
+ or (
+ error( loc("No such cache '%1'", $type) ),
+ return
+ );
+
+ return $self->_flush( list => $aref );
+}
+
+=pod
+
+=head2 @mods = $cb->installed()
+
+Returns a list of module objects of all your installed modules.
+If an error occurs, it will return false.
+
+See L<CPANPLUS::Module> for the operations you can perform on a
+module object.
+
+=cut
+
+sub installed {
+ my $self = shift;
+ my $aref = $self->_all_installed;
+
+ return @$aref if $aref;
+ return;
+}
+
+=pod
+
+=head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] )
+
+Creates a local mirror of CPAN, of only the most recent sources in a
+location you specify. If you set this location equal to a custom host
+in your C<CPANPLUS::Config> you can use your local mirror to install
+from.
+
+It takes the following arguments:
+
+=over 4
+
+=item path
+
+The location where to create the local mirror.
+
+=item index_files
+
+Enable/disable fetching of index files. You can disable fetching of the
+index files if you don't plan to use the local mirror as your primary
+site, or if you'd like up-to-date index files be fetched from elsewhere.
+
+Defaults to true.
+
+=item force
+
+Forces refetching of packages, even if they are there already.
+
+Defaults to whatever setting you have in your C<CPANPLUS::Config>.
+
+=item verbose
+
+Prints more messages about what its doing.
+
+Defaults to whatever setting you have in your C<CPANPLUS::Config>.
+
+=back
+
+Returns true on success and false on error.
+
+=cut
+
+sub local_mirror {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($path, $index, $force, $verbose);
+ my $tmpl = {
+ path => { default => $conf->get_conf('base'),
+ store => \$path },
+ index_files => { default => 1, store => \$index },
+ force => { default => $conf->get_conf('force'),
+ store => \$force },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ unless( -d $path ) {
+ $self->_mkdir( dir => $path )
+ or( error( loc( "Could not create '%1', giving up", $path ) ),
+ return
+ );
+ } elsif ( ! -w _ ) {
+ error( loc( "Could not write to '%1', giving up", $path ) );
+ return;
+ }
+
+ my $flag;
+ AUTHOR: {
+ for my $auth ( sort { $a->cpanid cmp $b->cpanid }
+ values %{$self->author_tree}
+ ) {
+
+ MODULE: {
+ my $i;
+ for my $mod ( $auth->modules ) {
+ my $fetchdir = File::Spec->catdir( $path, $mod->path );
+
+ my %opts = (
+ verbose => $verbose,
+ force => $force,
+ fetchdir => $fetchdir,
+ );
+
+ ### only do this the for the first module ###
+ unless( $i++ ) {
+ $mod->_get_checksums_file(
+ %opts
+ ) or (
+ error( loc( "Could not fetch %1 file, " .
+ "skipping author '%2'",
+ CHECKSUMS, $auth->cpanid ) ),
+ $flag++, next AUTHOR
+ );
+ }
+
+ $mod->fetch( %opts )
+ or( error( loc( "Could not fetch '%1'", $mod->module ) ),
+ $flag++, next MODULE
+ );
+ } }
+ } }
+
+ if( $index ) {
+ for my $name (qw[auth dslip mod]) {
+ $self->_update_source(
+ name => $name,
+ verbose => $verbose,
+ path => $path,
+ ) or ( $flag++, next );
+ }
+ }
+
+ return !$flag;
+}
+
+=pod
+
+=head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL])
+
+Writes out a snapshot of your current installation in C<CPAN> bundle
+style. This can then be used to install the same modules for a
+different or on a different machine by issuing the following commands:
+
+ ### using the default shell:
+ CPAN Terminal> i file://path/to/Snapshot_XXYY.pm
+
+ ### using the API
+ $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' );
+ $modobj->install;
+
+It will, by default, write to an 'autobundle' directory under your
+cpanplus homedirectory, but you can override that by supplying a
+C<path> argument.
+
+It will return the location of the output file on success and false on
+failure.
+
+=cut
+
+sub autobundle {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($path,$force,$verbose);
+ my $tmpl = {
+ force => { default => $conf->get_conf('force'), store => \$force },
+ verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+ path => { default => File::Spec->catdir(
+ $conf->get_conf('base'),
+ $self->_perl_version( perl => $^X ),
+ $conf->_get_build('distdir'),
+ $conf->_get_build('autobundle') ),
+ store => \$path },
+ };
+
+ check($tmpl, \%hash) or return;
+
+ unless( -d $path ) {
+ $self->_mkdir( dir => $path )
+ or( error(loc("Could not create directory '%1'", $path ) ),
+ return
+ );
+ }
+
+ my $name; my $file;
+ { ### default filename for the bundle ###
+ my($year,$month,$day) = (localtime)[5,4,3];
+ $year += 1900; $month++;
+
+ my $ext = 0;
+
+ my $prefix = $conf->_get_build('autobundle_prefix');
+ my $format = "${prefix}_%04d_%02d_%02d_%02d";
+
+ BLOCK: {
+ $name = sprintf( $format, $year, $month, $day, $ext);
+
+ $file = File::Spec->catfile( $path, $name . '.pm' );
+
+ -f $file ? ++$ext && redo BLOCK : last BLOCK;
+ }
+ }
+ my $fh;
+ unless( $fh = FileHandle->new( ">$file" ) ) {
+ error( loc( "Could not open '%1' for writing: %2", $file, $! ) );
+ return;
+ }
+
+ ### make sure we load the module tree *before* doing this, as it
+ ### starts to chdir all over the place
+ $self->module_tree;
+
+ my $string = join "\n\n",
+ map {
+ join ' ',
+ $_->module,
+ ($_->installed_version(verbose => 0) || 'undef')
+ } sort {
+ $a->module cmp $b->module
+ } $self->installed;
+
+ my $now = scalar localtime;
+ my $head = '=head1';
+ my $pkg = __PACKAGE__;
+ my $version = $self->VERSION;
+ my $perl_v = join '', `$^X -V`;
+
+ print $fh <<EOF;
+package $name;
+
+\$VERSION = '0.01';
+
+1;
+
+__END__
+
+$head NAME
+
+$name - Snapshot of your installation at $now
+
+$head SYNOPSIS
+
+To install the modules from this snapshot, run:
+
+ cpanp -i file://full/path/to/${name}.pm
+
+$head CONTENTS
+
+$string
+
+$head CONFIGURATION
+
+$perl_v
+
+$head AUTHOR
+
+This bundle has been generated autotomatically by
+ $pkg $version
+
+EOF
+
+ close $fh;
+
+ return $file;
+}
+
+=head2 $bool = $cb->save_state
+
+Explicit command to save memory state to disk. This can be used to save
+information to disk about where a module was extracted, the result of
+C<make test>, etc. This will then be re-loaded into memory when a new
+session starts.
+
+The capability of saving state to disk depends on the source engine
+being used (See C<CPANPLUS::Config> for the option to choose your
+source engine). The default storage engine supports this option.
+
+Most users will not need this command, but it can handy for automated
+systems like setting up CPAN smoke testers.
+
+The method will return true if it managed to save the state to disk,
+or false if it did not.
+
+=cut
+
+sub save_state {
+ my $self = shift;
+ return $self->_save_state( @_ );
+}
+
+
+### XXX these wrappers are not individually tested! only the underlying
+### code through source.t and indirectly trought he CustomSource plugin.
+=pod
+
+=head1 CUSTOM MODULE SOURCES
+
+Besides the sources as provided by the general C<CPAN> mirrors, it's
+possible to add your own sources list to your C<CPANPLUS> index.
+
+The methodology behind this works much like C<Debian's apt-sources>.
+
+The methods below show you how to make use of this functionality. Also
+note that most of these methods are available through the default shell
+plugin command C</cs>, making them available as shortcuts through the
+shell and via the commandline.
+
+=head2 %files = $cb->list_custom_sources
+
+Returns a mapping of registered custom sources and their local indices
+as follows:
+
+ /full/path/to/local/index => http://remote/source
+
+Note that any file starting with an C<#> is being ignored.
+
+=cut
+
+sub list_custom_sources {
+ return shift->__list_custom_module_sources( @_ );
+}
+
+=head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] );
+
+Adds an C<URI> to your own sources list and mirrors its index. See the
+documentation on C<< $cb->update_custom_source >> on how this is done.
+
+Returns the full path to the local index on success, or false on failure.
+
+Note that when adding a new C<URI>, the change to the in-memory tree is
+not saved until you rebuild or save the tree to disk again. You can do
+this using the C<< $cb->reload_indices >> method.
+
+=cut
+
+sub add_custom_source {
+ return shift->_add_custom_module_source( @_ );
+}
+
+=head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] );
+
+Removes an C<URI> from your own sources list and removes its index.
+
+To find out what C<URI>s you have as part of your own sources list, use
+the C<< $cb->list_custom_sources >> method.
+
+Returns the full path to the deleted local index file on success, or false
+on failure.
+
+=cut
+
+### XXX do clever dispatching based on arg number?
+sub remove_custom_source {
+ return shift->_remove_custom_module_source( @_ );
+}
+
+=head2 $bool = $cb->update_custom_source( [remote => URI] );
+
+Updates the indexes for all your custom sources. It does this by fetching
+a file called C<packages.txt> in the root of the custom sources's C<URI>.
+If you provide the C<remote> argument, it will only update the index for
+that specific C<URI>.
+
+Here's an example of how custom sources would resolve into index files:
+
+ file:///path/to/sources => file:///path/to/sources/packages.txt
+ http://example.com/sources => http://example.com/sources/packages.txt
+ ftp://example.com/sources => ftp://example.com/sources/packages.txt
+
+The file C<packages.txt> simply holds a list of packages that can be found
+under the root of the C<URI>. This file can be automatically generated for
+you when the remote source is a C<file:// URI>. For C<http://>, C<ftp://>,
+and similar, the administrator of that repository should run the method
+C<< $cb->write_custom_source_index >> on the repository to allow remote
+users to index it.
+
+For details, see the C<< $cb->write_custom_source_index >> method below.
+
+All packages that are added via this mechanism will be attributed to the
+author with C<CPANID> C<LOCAL>. You can use this id to search for all
+added packages.
+
+=cut
+
+sub update_custom_source {
+ my $self = shift;
+
+ ### if it mentions /remote/, the request is to update a single uri,
+ ### not all the ones we have, so dispatch appropriately
+ my $rv = grep( /remote/i, @_)
+ ? $self->__update_custom_module_source( @_ )
+ : $self->__update_custom_module_sources( @_ );
+
+ return $rv;
+}
+
+=head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] );
+
+Writes the index for a custom repository root. Most users will not have to
+worry about this, but administrators of a repository will need to make sure
+their indexes are up to date.
+
+The index will be written to a file called C<packages.txt> in your repository
+root, which you can specify with the C<path> argument. You can override this
+location by specifying the C<to> argument, but in normal operation, that should
+not be required.
+
+Once the index file is written, users can then add the C<URI> pointing to
+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.
+
+=cut
+
+sub write_custom_source_index {
+ return shift->__write_custom_module_index( @_ );
+}
+
+1;
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>,
+L<CPANPLUS::Selfupdate>
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+__END__
+
+todo:
+sub dist { # not sure about this one -- probably already done
+ enough in Module.pm
+sub reports { # in Module.pm, wrapper here
+
+