diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm | 1344 |
1 files changed, 0 insertions, 1344 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm deleted file mode 100644 index 85559dc04ff..00000000000 --- a/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm +++ /dev/null @@ -1,1344 +0,0 @@ -package CPANPLUS::Backend; -use deprecate; - -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 = "0.9135"; - -### 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 - programmer's interface to CPANPLUS - -=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 ? 1 : 0 ), - 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.pm - -=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 arbitrary 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; - } - - # Stolen from cpanminus to support 'Module/Install.pm' - # type input - if ( ( my $tmpmod = $mod ) =~ s/\.pm$//i ) { - my ($volume, $dirs, $file) = File::Spec->splitpath( $tmpmod ); - $tmpmod = join '::', grep { $_ } File::Spec->splitdir( $dirs ), $file; - ### perhaps we can find it in the module tree? - my $maybe = $self->module_tree( $tmpmod ); - return $maybe if IS_MODOBJ->( module => $maybe ); - } - - ### 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 through 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 - - |