| 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 - 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 |
| |
| |