From: Rafael Garcia-Suarez Date: Tue, 10 Apr 2007 07:42:33 +0000 (+0000) Subject: Add CPANPLUS 0.78 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6aaee015312976007994b80b72c65ab6b6237774;p=p5sagit%2Fp5-mst-13.2.git Add CPANPLUS 0.78 p4raw-id: //depot/perl@30883 --- diff --git a/MANIFEST b/MANIFEST index 12caf9e..adae648 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1571,6 +1571,98 @@ lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions lib/CPAN/PAUSE2003.pub CPAN public key lib/CPAN/PAUSE2005.pub CPAN public key lib/CPAN/PAUSE2007.pub CPAN public key +lib/CPANPLUS/Backend.pm CPANPLUS +lib/CPANPLUS/Backend/RV.pm CPANPLUS +lib/CPANPLUS/bin/cpan2dist the cpan2dist utility +lib/CPANPLUS/bin/cpanp the cpanp utility +lib/CPANPLUS/bin/cpanp-run-perl the cpanp-run-perl utility +lib/CPANPLUS/Config.pm CPANPLUS +lib/CPANPLUS/Configure.pm CPANPLUS +lib/CPANPLUS/Configure/Setup.pm CPANPLUS +lib/CPANPLUS/Dist/Base.pm CPANPLUS +lib/CPANPLUS/Dist/MM.pm CPANPLUS +lib/CPANPLUS/Dist.pm CPANPLUS +lib/CPANPLUS/Dist/Sample.pm CPANPLUS +lib/CPANPLUS/Error.pm CPANPLUS +lib/CPANPLUS/FAQ.pod CPANPLUS +lib/CPANPLUS/Hacking.pod CPANPLUS +lib/CPANPLUS/inc.pm CPANPLUS +lib/CPANPLUS/Internals/Constants.pm CPANPLUS +lib/CPANPLUS/Internals/Constants/Report.pm CPANPLUS +lib/CPANPLUS/Internals/Extract.pm CPANPLUS +lib/CPANPLUS/Internals/Fetch.pm CPANPLUS +lib/CPANPLUS/Internals.pm CPANPLUS +lib/CPANPLUS/Internals/Report.pm CPANPLUS +lib/CPANPLUS/Internals/Search.pm CPANPLUS +lib/CPANPLUS/Internals/Source.pm CPANPLUS +lib/CPANPLUS/Internals/Utils/Autoflush.pm CPANPLUS +lib/CPANPLUS/Internals/Utils.pm CPANPLUS +lib/CPANPLUS/Module/Author/Fake.pm CPANPLUS +lib/CPANPLUS/Module/Author.pm CPANPLUS +lib/CPANPLUS/Module/Checksums.pm CPANPLUS +lib/CPANPLUS/Module/Fake.pm CPANPLUS +lib/CPANPLUS/Module.pm CPANPLUS +lib/CPANPLUS/Module/Signature.pm CPANPLUS +lib/CPANPLUS.pm CPANPLUS +lib/CPANPLUS/Selfupdate.pm CPANPLUS +lib/CPANPLUS/Shell/Classic.pm CPANPLUS +lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod CPANPLUS +lib/CPANPLUS/Shell/Default/Plugins/Remote.pm CPANPLUS +lib/CPANPLUS/Shell/Default/Plugins/Source.pm CPANPLUS +lib/CPANPLUS/Shell/Default.pm CPANPLUS +lib/CPANPLUS/Shell.pm CPANPLUS +lib/CPANPLUS/t/00_CPANPLUS-Inc.t CPANPLUS tests +lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t CPANPLUS tests +lib/CPANPLUS/t/01_CPANPLUS-Configure.t CPANPLUS tests +lib/CPANPLUS/t/02_CPANPLUS-Internals.t CPANPLUS tests +lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t CPANPLUS tests +lib/CPANPLUS/t/04_CPANPLUS-Module.t CPANPLUS tests +lib/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t CPANPLUS tests +lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t CPANPLUS tests +lib/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t CPANPLUS tests +lib/CPANPLUS/t/08_CPANPLUS-Backend.t CPANPLUS tests +lib/CPANPLUS/t/09_CPANPLUS-Internals-Search.t CPANPLUS tests +lib/CPANPLUS/t/10_CPANPLUS-Error.t CPANPLUS tests +lib/CPANPLUS/t/19_CPANPLUS-Dist.t CPANPLUS tests +lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t CPANPLUS tests +lib/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t CPANPLUS tests +lib/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t CPANPLUS tests +lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.readme CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.readme CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.readme CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.readme CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-cpanplus/01mailrc.txt.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-cpanplus/02packages.details.txt.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-cpanplus/03modlist.data.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-cpanplus/sourcefiles.2.15.stored.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/01mailrc.txt.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/02packages.details.txt.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/03modlist.data.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/inc/conf.pl CPANPLUS tests lib/CPAN.pm Interface to Comprehensive Perl Archive Network lib/CPAN/Queue.pm queueing system for CPAN.pm lib/CPAN/SIGNATURE CPAN public key @@ -2398,8 +2490,8 @@ lib/Pod/Simple/t/html02.t Pod::Simple test file lib/Pod/Simple/t/html03.t Pod::Simple test file lib/Pod/Simple/t/htmlbat.t Pod::Simple test file lib/Pod/Simple/TiedOutFH.pm Pod::Simple::TiedOutFH -lib/Pod/Simple/t/items.t Pod::Simple test file lib/Pod/Simple/t/items02.t Pod::Simple test file +lib/Pod/Simple/t/items.t Pod::Simple test file lib/Pod/Simple/t/itemstar.t Pod::Simple test file lib/Pod/Simple/t/junk1o.txt Pod::Simple test file lib/Pod/Simple/t/junk1.pod Pod::Simple test file @@ -3784,7 +3876,10 @@ util.h Dummy header utils/c2ph.PL program to translate dbx stabs to perl utils/config_data.PL Module::Build tool utils/corelist.PL Module::CoreList +utils/cpan2dist.PL the cpan2dist utility utils/cpan.PL easily interact with CPAN from the command line +utils/cpanp.PL the cpanp utility +utils/cpanp-run-perl.PL the cpanp-run-perl utility utils/dprofpp.PL Perl code profile post-processor utils/enc2xs.PL Encode module generator utils/h2ph.PL A thing to turn C .h files into perl .ph files diff --git a/installperl b/installperl index 0123e53..f4742ee 100755 --- a/installperl +++ b/installperl @@ -830,7 +830,7 @@ sub installlib { # the corelist script from lib/Module/CoreList/bin and ptar* in # lib/Archive/Tar/bin, the config_data script in lib/Module/Build/scripts # (they're installed later with other utils) - return if $name =~ /^(?:cpan|instmodsh|prove|corelist|ptar|ptardiff|config_data)\z/; + return if $name =~ /^(?:cpan|instmodsh|prove|corelist|ptar|cpan2dist|cpanp|cpanp-run-perl|ptardiff|config_data)\z/; # ignore the Makefiles return if $name =~ /^makefile$/i; # ignore the test extensions diff --git a/lib/CPANPLUS.pm b/lib/CPANPLUS.pm new file mode 100644 index 0000000..b30aa7f --- /dev/null +++ b/lib/CPANPLUS.pm @@ -0,0 +1,271 @@ +package CPANPLUS; + +use strict; +use Carp; + +use CPANPLUS::Error; +use CPANPLUS::Backend; + +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +BEGIN { + use Exporter (); + use vars qw( @EXPORT @ISA $VERSION ); + @EXPORT = qw( shell fetch get install ); + @ISA = qw( Exporter ); + $VERSION = "0.78"; #have to hardcode or cpan.org gets unhappy +} + +### purely for backward compatibility, so we can call it from the commandline: +### perl -MCPANPLUS -e 'install Net::SMTP' +sub install { + my $cpan = CPANPLUS::Backend->new; + my $mod = shift or ( + error(loc("No module specified!")), return + ); + + if ( ref $mod ) { + error( loc( "You passed an object. Use %1 for OO style interaction", + 'CPANPLUS::Backend' )); + return; + + } else { + my $obj = $cpan->module_tree($mod) or ( + error(loc("No such module '%1'", $mod)), + return + ); + + my $ok = $obj->install; + + $ok + ? msg(loc("Installing of %1 successful", $mod),1) + : msg(loc("Installing of %1 failed", $mod),1); + + return $ok; + } +} + +### simply downloads a module and stores it +sub fetch { + my $cpan = CPANPLUS::Backend->new; + + my $mod = shift or ( + error(loc("No module specified!")), return + ); + + if ( ref $mod ) { + error( loc( "You passed an object. Use %1 for OO style interaction", + 'CPANPLUS::Backend' )); + return; + + } else { + my $obj = $cpan->module_tree($mod) or ( + error(loc("No such module '%1'", $mod)), + return + ); + + my $ok = $obj->fetch( fetchdir => '.' ); + + $ok + ? msg(loc("Fetching of %1 successful", $mod),1) + : msg(loc("Fetching of %1 failed", $mod),1); + + return $ok; + } +} + +### alias to fetch() due to compatibility with cpan.pm ### +sub get { fetch(@_) } + + +### purely for backwards compatibility, so we can call it from the commandline: +### perl -MCPANPLUS -e 'shell' +sub shell { + my $option = shift; + + ### since the user can specify the type of shell they wish to start + ### when they call the shell() function, we have to eval the usage + ### of CPANPLUS::Shell so we can set up all the checks properly + eval { require CPANPLUS::Shell; CPANPLUS::Shell->import($option) }; + die $@ if $@; + + my $cpan = CPANPLUS::Shell->new(); + + $cpan->shell(); +} + +1; + +__END__ + +=pod + +=head1 NAME + +CPANPLUS - API & CLI access to the CPAN mirrors + +=head1 SYNOPSIS + + ### standard invocation from the command line + $ cpanp + $ cpanp -i Some::Module + + $ perl -MCPANPLUS -eshell + $ perl -MCPANPLUS -e'fetch Some::Module' + + +=head1 DESCRIPTION + +The C library is an API to the C mirrors and a +collection of interactive shells, commandline programs, etc, +that use this API. + +=head1 GUIDE TO DOCUMENTATION + +=head2 GENERAL USAGE + +This is the document you are currently reading. It describes +basic usage and background information. Its main purpose is to +assist the user who wants to learn how to invoke CPANPLUS +and install modules from the commandline and to point you +to more indepth reading if required. + +=head2 API REFERENCE + +The C API is meant to let you programmatically +interact with the C mirrors. The documentation in +L shows you how to create an object +capable of interacting with those mirrors, letting you +create & retrieve module objects. +L shows you how you can use these module +objects to perform actions like installing and testing. + +The default shell, documented in L +is also scriptable. You can use its API to dispatch calls +from your script to the CPANPLUS Shell. + +=cut + +=head1 COMMANDLINE TOOLS + +=head2 STARTING AN INTERACTIVE SHELL + +You can start an interactive shell by running either of +the two following commands: + + $ cpanp + + $ perl -MCPANPLUS -eshell + +All commans available are listed in the interactive shells +help menu. See C or L +for instructions on using the default shell. + +=head2 CHOOSE A SHELL + +By running C without arguments, you will start up +the shell specified in your config, which defaults to +L. There are more shells available. +C itself ships with an emulation shell called +L that looks and feels just like +the old C shell. + +You can start this shell by typing: + + $ perl -MCPANPLUS -e'shell Classic' + +Even more shells may be available from C. + +Note that if you have changed your default shell in your +configuration, that shell will be used instead. If for +some reason there was an error with your specified shell, +you will be given the default shell. + +=head2 BUILDING PACKAGES + +C is a commandline tool to convert any distribution +from C into a package in the format of your choice, like +for example C<.deb> or C. + +See C for details. + + +=head1 FUNCTIONS + +For quick access to common commands, you may use this module, +C rather than the full programmatic API situated in +C. This module offers the following functions: + +=head2 $bool = install( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz ) + +This function requires the full name of the module, which is case +sensitive. The module name can also be provided as a fully +qualified file name, beginning with a I, relative to +the /authors/id directory on a CPAN mirror. + +It will download, extract and install the module. + +=head2 $where = fetch( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz ) + +Like install, fetch needs the full name of a module or the fully +qualified file name, and is case sensitive. + +It will download the specified module to the current directory. + +=head2 $where = get( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz ) + +Get is provided as an alias for fetch for compatibility with +CPAN.pm. + +=head2 shell() + +Shell starts the default CPAN shell. You can also start the shell +by using the C command, which will be installed in your +perl bin. + +=head1 FAQ + +For frequently asked questions and answers, please consult the +C manual. + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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, L, L, L, L, L + +=head1 CONTACT INFORMATION + +=over 4 + +=item * Bug reporting: +I + +=item * Questions & suggestions: +I + +=back + + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Backend.pm b/lib/CPANPLUS/Backend.pm new file mode 100644 index 0000000..50b13c4 --- /dev/null +++ b/lib/CPANPLUS/Backend.pm @@ -0,0 +1,1061 @@ +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 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 +libraries. + +=head1 ENVIRONMENT + +When C is loaded, which is necessary for just +about every operation, the environment variable +C is set to the current process id. + +Additionally, the environment variable C +will be set to the version of C. + +This information might be useful somehow to spawned processes. + +=head1 METHODS + +=head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] ) + +This method returns a new C object. +This also initialises the config corresponding to this object. +You have two choices in this: + +=over 4 + +=item Provide a valid C object + +This will be used verbatim. + +=item No arguments + +Your default config will be loaded and used. + +=back + +New will return a C 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 will try to look up these module names and +return the corresponding module objects instead. + +See L 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 } @_) { + push @rv, $modtree->{$name} || ''; + } + 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 will try to look up these author names and +return the corresponding author objects instead. + +See L 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 object. + +See L 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 object. + +See the L 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 enables you to search for either module or author objects, +based on their data. The C you can specify is any of the +accessors specified in C or +C. C will determine by the C 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, so read that manpage for details. + +The search is an C search, meaning that if C of the criteria +match, the search is considered to be successful. + +You can specify the result of a previous search as C 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 searches. + +Returns a list of module or author objects on success and false +on failure. + +See L for the operations you can perform on a +module object. +See L for the operations you can perform on +an author object. + +=cut + +sub search { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + + my ($data,$type); + my $tmpl = { + type => { required => 1, allow => [CPANPLUS::Module->accessors(), + CPANPLUS::Module::Author->accessors()], store => \$type }, + allow => { required => 1, default => [ ], strict_type => 1 }, + }; + + my $args = 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 can understand. + +See the equivalent method in C for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C 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 can understand. + +See the equivalent method in C for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C 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 can understand. + +See the equivalent method in C for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C 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 can understand. + +See the equivalent method in C for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C 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 can understand. + +See the equivalent method in C for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C 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 can understand. + +See the equivalent method in C for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C 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 = @_; + + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::ALLOW_UNKNOWN = 1; + + my ($mods); + my $tmpl = { + modules => { default => [], strict_type => 1, + required => 1, store => \$mods }, + }; + + my $args = 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 ) + +C tries to find a C object that +matches your query. Here's a list of examples you could give to +C; + +=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 + +=back + +These items would all come up with a C object for +C. The ones marked explicitly as being version 1.06 +would give back a C object of that version. +Even if the version on CPAN is currently higher. + +If C 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 object for you, that you can use just like the +real thing. + +See L for the operations you can perform on a +module object. + +If even this fancy guessing doesn't enable C 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 ); + } + + ### 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 ); + + 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) = + $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, + package => $pkg . '-' . $version . '.' . + $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 { + + 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 is set to true, this will fetch new source files +from your CPAN mirror. Otherwise, C will do its +usual cache checking and only update them if they are out of date. + +By default, C 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 + +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 + +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 + +Information about modules such as prerequisites and whether +installation succeeded, failed, or was not attempted. + +=item * C + +This resets PERL5LIB, which is changed to ensure that while installing +modules they are in our @INC. + +=item * C + +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 + +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 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 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. This is ok if you don't plan +to use the local mirror as your primary sites, 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. + +=item verbose + +Prints more messages about what its doing. + +Defaults to whatever setting you have in your C. + +=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 bundle +style. This can then be used to install the same modules for a +different or on a different machine. + +It will, by default, write to an 'autobundle' directory under your +cpanplus homedirectory, but you can override that by supplying a +C 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; + } + + 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 <bug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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, L, L + +=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 + + diff --git a/lib/CPANPLUS/Backend/RV.pm b/lib/CPANPLUS/Backend/RV.pm new file mode 100644 index 0000000..9edbe04 --- /dev/null +++ b/lib/CPANPLUS/Backend/RV.pm @@ -0,0 +1,144 @@ +package CPANPLUS::Backend::RV; + +use strict; +use vars qw[$STRUCT]; + + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use IPC::Cmd qw[can_run run]; +use Params::Check qw[check]; + +use base 'Object::Accessor'; + +local $Params::Check::VERBOSE = 1; + + +=pod + +=head1 NAME + +CPANPLUS::Backend::RV + +=head1 SYNOPSIS + + ### create a CPANPLUS::Backend::RV object + $backend_rv = CPANPLUS::Backend::RV->new( + ok => $boolean, + args => $args, + rv => $return_value + function => $calling_function ); + + ### if you have a CPANPLUS::Backend::RV object + $passed_args = $backend_rv->args; # args passed to function + $ok = $backend_rv->ok; # boolean indication overall + # result of the call + $function = $backend_rv->fucntion # name of the calling + # function + $rv = $backend_rv->rv # the actual return value + # of the calling function + +=head1 DESCRIPTION + +This module provides return value objects for multi-module +calls to CPANPLUS::Backend. In boolean context, it returns the status +of the overall result (ie, the same as the C method would). + +=head1 METHODS + +=head2 new( ok => BOOL, args => DATA, rv => DATA, [function => $method_name] ) + +Creates a new CPANPLUS::Backend::RV object from the data provided. +This method should only be called by CPANPLUS::Backend functions. +The accessors may be used by users inspecting an RV object. + +All the argument names can be used as accessors later to retrieve the +data. + +Arguments: + +=over 4 + +=item ok + +Boolean indicating overall success + +=item args + +The arguments provided to the function that returned this rv object. +Useful to inspect later to see what was actually passed to the function +in case of an error. + +=item rv + +An arbitrary data structure that has the detailed return values of each +of your multi-module calls. + +=item function + +The name of the function that created this rv object. +Can be explicitly passed. If not, C will try to deduce the name +from C information. + +=back + +=cut + +sub new { + my $class = shift; + my %hash = @_; + + my $tmpl = { + ok => { required => 1, allow => BOOLEANS }, + args => { required => 1 }, + rv => { required => 1 }, + function => { default => CALLING_FUNCTION->() }, + }; + + my $args = check( $tmpl, \%hash ) or return; + my $self = bless {}, $class; + +# $self->mk_accessors( qw[ok args function rv] ); + $self->mk_accessors( keys %$tmpl ); + + ### set the values passed in the struct ### + while( my($key,$val) = each %$args ) { + $self->$key( $val ); + } + + return $self; +} + +sub _ok { return shift->ok } +#sub _stringify { Carp::carp( "stringifying!" ); overload::StrVal( shift ) } + +### make it easier to check if($rv) { foo() } +### this allows people to not have to explicitly say +### if( $rv->ok ) { foo() } +### XXX add an explicit stringify, so it doesn't fall back to "bool"? :( +use overload bool => \&_ok, +# '""' => \&_stringify, + fallback => 1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/CPANPLUS/Config.pm b/lib/CPANPLUS/Config.pm new file mode 100644 index 0000000..2516559 --- /dev/null +++ b/lib/CPANPLUS/Config.pm @@ -0,0 +1,264 @@ +package CPANPLUS::Config; + +use strict; +use warnings; + +use base 'Object::Accessor'; + +use base 'CPANPLUS::Internals::Utils'; + +use Config; +use File::Spec; +use Module::Load; +use CPANPLUS; +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Basename qw[dirname]; +use IPC::Cmd qw[can_run]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Module::Load::Conditional qw[check_install]; + +my $Conf = { + '_fetch' => { + 'blacklist' => [ 'ftp' ], + }, + 'conf' => { + ### default host list + 'hosts' => [ + { + 'scheme' => 'ftp', + 'path' => '/pub/CPAN/', + 'host' => 'ftp.cpan.org' + }, + { + 'scheme' => 'http', + 'path' => '/', + 'host' => 'www.cpan.org' + }, + { + 'scheme' => 'ftp', + 'path' => '/pub/CPAN/', + 'host' => 'ftp.nl.uu.net' + }, + { + 'scheme' => 'ftp', + 'path' => '/pub/CPAN/', + 'host' => 'cpan.valueclick.com' + }, + { + 'scheme' => 'ftp', + 'path' => '/pub/languages/perl/CPAN/', + 'host' => 'ftp.funet.fi' + } + ], + 'allow_build_interactivity' => 1, + 'base' => File::Spec->catdir( + __PACKAGE__->_home_dir, DOT_CPANPLUS ), + 'buildflags' => '', + 'cpantest' => 0, + 'cpantest_mx' => '', + 'debug' => 0, + 'dist_type' => '', + 'email' => DEFAULT_EMAIL, + 'extractdir' => '', + 'fetchdir' => '', + 'flush' => 1, + 'force' => 0, + 'lib' => [], + 'makeflags' => '', + 'makemakerflags' => '', + 'md5' => ( + check_install( module => 'Digest::MD5' ) ? 1 : 0 ), + 'no_update' => 0, + 'passive' => 1, + ### if we dont have c::zlib, we'll need to use /bin/tar or we + ### can not extract any files. Good time to change the default + 'prefer_bin' => (eval {require Compress::Zlib; 1}?0:1), + 'prefer_makefile' => 1, + 'prereqs' => PREREQ_ASK, + 'shell' => 'CPANPLUS::Shell::Default', + 'show_startup_tip' => 1, + 'signature' => ( (can_run( 'gpg' ) || + check_install( module => 'Crypt::OpenPGP' ))?1:0 ), + 'skiptest' => 0, + 'storable' => ( + check_install( module => 'Storable' ) ? 1 : 0 ), + 'timeout' => 300, + 'verbose' => $ENV{PERL5_CPANPLUS_VERBOSE} || 0, + 'write_install_logs' => 1, + }, + ### Paths get stripped of whitespace on win32 in the constructor + ### sudo gets emptied if there's no need for it in the constructor + 'program' => { + 'editor' => ( $ENV{'EDITOR'} || $ENV{'VISUAL'} || + can_run('vi') || can_run('pico') + ), + 'make' => ( can_run($Config{'make'}) || can_run('make') ), + 'pager' => ( $ENV{'PAGER'} || can_run('less') || can_run('more') ), + ### no one uses this feature anyway, and it's only working for EU::MM + ### and not for module::build + #'perl' => '', + 'shell' => ( $^O eq 'MSWin32' ? $ENV{COMSPEC} : $ENV{SHELL} ), + 'sudo' => ( $> # check for all install dirs! + # installsiteman3dir is a 5.8'ism.. don't check + # it on 5.6.x... + ? ( -w $Config{'installsitelib'} && + ( defined $Config{'installsiteman3dir'} && + -w $Config{'installsiteman3dir'} + ) && + -w $Config{'installsitebin'} + ? undef + : can_run('sudo') + ) + : can_run('sudo') + ), + ### perlwrapper that allows us to turn on autoflushing + 'perlwrapper' => ( ### parallel to your cpanp/cpanp-boxed + do { my $f = File::Spec->rel2abs( + File::Spec->catdir( + dirname($0), 'cpanp-run-perl' + ) + ); + -e $f ? $f : undef + } || + + ### parallel to your CPANPLUS.pm: + ### $INC{cpanplus}/../bin/cpanp-run-perl + do { my $f = File::Spec->rel2abs( + File::Spec->catdir( + dirname( $INC{'CPANPLUS.pm'} ), + '..', # lib dir + 'bin', # bin dir + 'cpanp-run-perl' + ) + ); + -e $f ? $f : undef + } || + ### you installed CPANPLUS in a custom prefix, + ### so go paralel to /that/. PREFIX=/tmp/cp + ### would put cpanp-run-perl in /tmp/cp/bin and + ### CPANPLUS.pm in + ### /tmp/cp/lib/perl5/site_perl/5.8.8 + do { my $f = File::Spec->rel2abs( + File::Spec->catdir( + dirname( $INC{'CPANPLUS.pm'} ), + '..', '..', '..', '..', # 4x updir + 'bin', # bin dir + 'cpanp-run-perl' + ) + ); + -e $f ? $f : undef + } || + + ### in your path -- take this one last, the + ### previous two assume extracted tarballs + ### or user installs + ### note that we don't use 'can_run' as it's + ### not an executable, just a wrapper... + do { my $rv; + for (split(/\Q$Config::Config{path_sep}\E/, + $ENV{PATH}), File::Spec->curdir + ) { + my $path = File::Spec->catfile( + $_, 'cpanp-run-perl' ); + if( -e $path ) { + $rv = $path; + last; + } + } + + $rv || undef; + } || + + ### XXX try to be a no-op instead then.. + ### cross your fingers... + ### pass '-P' to perl: "run program through C + ### preprocessor before compilation" + do { + error(loc( + "Could not find the '%1' in your path". + "--this may be a problem.\n". + "Please locate this program and set ". + "your '%1' config entry to its path.\n". + "Attempting to provide a reasonable ". + "fallback...", + 'cpanp-run-perl', 'perlwrapper' + )); + '-P' + }, + ), + }, + + ### _source, _build and _mirror are supposed to be static + ### no changes should be needed unless pause/cpan changes + '_source' => { + 'hosts' => 'MIRRORED.BY', + 'auth' => '01mailrc.txt.gz', + 'stored' => 'sourcefiles', + 'dslip' => '03modlist.data.gz', + 'update' => '86400', + 'mod' => '02packages.details.txt.gz' + }, + '_build' => { + 'plugins' => 'plugins', + 'moddir' => 'build', + 'startdir' => '', + 'distdir' => 'dist', + 'autobundle' => 'autobundle', + 'autobundle_prefix' => 'Snapshot', + 'autdir' => 'authors', + 'install_log_dir' => 'install-logs', + 'sanity_check' => 1, + }, + '_mirror' => { + 'base' => 'authors/id/', + 'auth' => 'authors/01mailrc.txt.gz', + 'dslip' => 'modules/03modlist.data.gz', + 'mod' => 'modules/02packages.details.txt.gz' + }, +}; + +sub new { + my $class = shift; + my $obj = $class->SUPER::new; + + $obj->mk_accessors( keys %$Conf ); + + for my $acc ( keys %$Conf ) { + my $subobj = Object::Accessor->new; + $subobj->mk_accessors( keys %{$Conf->{$acc}} ); + + ### read in all the settings from the sub accessors; + for my $subacc ( $subobj->ls_accessors ) { + $subobj->$subacc( $Conf->{$acc}->{$subacc} ); + } + + ### now store it in the parent object + $obj->$acc( $subobj ); + } + + $obj->_clean_up_paths; + + ### shut up IPC::Cmd warning about not findin IPC::Run on win32 + $IPC::Cmd::WARN = 0; + + return $obj; +} + +sub _clean_up_paths { + my $self = shift; + + ### clean up paths if we are on win32 + if( $^O eq 'MSWin32' ) { + for my $pgm ( $self->program->ls_accessors ) { + $self->program->$pgm( + Win32::GetShortPathName( $self->program->$pgm ) + ) if $self->program->$pgm =~ /\s+/; + } + } + + return 1; +} + +1; diff --git a/lib/CPANPLUS/Configure.pm b/lib/CPANPLUS/Configure.pm new file mode 100644 index 0000000..51d74ef --- /dev/null +++ b/lib/CPANPLUS/Configure.pm @@ -0,0 +1,601 @@ +package CPANPLUS::Configure; +use strict; + + +use CPANPLUS::Internals::Constants; +use CPANPLUS::Error; +use CPANPLUS::Config; + +use Log::Message; +use Module::Load qw[load]; +use Params::Check qw[check]; +use File::Basename qw[dirname]; +use Module::Loaded (); +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use vars qw[$AUTOLOAD $VERSION $MIN_CONFIG_VERSION]; +use base qw[CPANPLUS::Internals::Utils]; + +local $Params::Check::VERBOSE = 1; + +### require, avoid circular use ### +require CPANPLUS::Internals; +$VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION; + +### can't use O::A as we're using our own AUTOLOAD to get to +### the config options. +for my $meth ( qw[conf]) { + no strict 'refs'; + + *$meth = sub { + my $self = shift; + $self->{'_'.$meth} = $_[0] if @_; + return $self->{'_'.$meth}; + } +} + + +=pod + +=head1 NAME + +CPANPLUS::Configure + +=head1 SYNOPSIS + + $conf = CPANPLUS::Configure->new( ); + + $bool = $conf->can_save; + $bool = $conf->save( $where ); + + @opts = $conf->options( $type ); + + $make = $conf->get_program('make'); + $verbose = $conf->set_conf( verbose => 1 ); + +=head1 DESCRIPTION + +This module deals with all the configuration issues for CPANPLUS. +Users can use objects created by this module to alter the behaviour +of CPANPLUS. + +Please refer to the C documentation on how to +obtain a C object. + +=head1 METHODS + +=head2 $Configure = CPANPLUS::Configure->new( load_configs => BOOL ) + +This method returns a new object. Normal users will never need to +invoke the C method, but instead retrieve the desired object via +a method call on a C object. + +The C parameter controls wether or not additional +user configurations are to be loaded or not. Defaults to C. + +=cut + +### store teh CPANPLUS::Config object in a closure, so we only +### initialize it once.. otherwise, on a 2nd ->new, settings +### from configs on top of this one will be reset +{ my $Config; + + sub new { + my $class = shift; + my %hash = @_; + + ### XXX pass on options to ->init() like rescan? + my ($load); + my $tmpl = { + load_configs => { default => 1, store => \$load }, + }; + + check( $tmpl, \%hash ) or ( + warn Params::Check->last_error, return + ); + + $Config ||= CPANPLUS::Config->new; + my $self = bless {}, $class; + $self->conf( $Config ); + + ### you want us to load other configs? + ### these can override things in the default config + $self->init if $load; + + return $self; + } +} + +=head2 $bool = $Configure->init( [rescan => BOOL]) + +Initialize the configure with other config files than just +the default 'CPANPLUS::Config'. + +Called from C to load user/system configurations + +If the C option is provided, your disk will be +examined again to see if there are new config files that +could be read. Defaults to C. + +Returns true on success, false on failure. + +=cut + +### move the Module::Pluggable detection to runtime, rather +### than compile time, so that a simple 'require CPANPLUS' +### doesn't start running over your filesystem for no good +### reason. Make sure we only do the M::P call once though. +### we use $loaded to mark it +{ my $loaded; + my $warned; + sub init { + my $self = shift; + my $obj = $self->conf; + my %hash = @_; + + my ($rescan); + my $tmpl = { + rescan => { default => 0, store => \$rescan }, + }; + + check( $tmpl, \%hash ) or ( + warn Params::Check->last_error, return + ); + + ### warn if we find an old style config specified + ### via environment variables + { my $env = ENV_CPANPLUS_CONFIG; + if( $ENV{$env} and not $warned ) { + $warned++; + error(loc("Specifying a config file in your environment " . + "using %1 is obsolete.\nPlease follow the ". + "directions outlined in %2 or use the '%3' command\n". + "in the default shell to use custom config files.", + $env, "CPANPLUS::Configure->save", 's save')); + } + } + + ### make sure that the homedir is included now + local @INC = ( CONFIG_USER_LIB_DIR->(), @INC ); + + ### only set it up once + if( !$loaded++ or $rescan ) { + ### find plugins & extra configs + ### check $home/.cpanplus/lib as well + require Module::Pluggable; + + Module::Pluggable->import( + search_path => ['CPANPLUS::Config'], + search_dirs => [ CONFIG_USER_LIB_DIR ], + except => qr/::SUPER$/, + sub_name => 'configs' + ); + } + + + ### do system config, user config, rest.. in that order + ### apparently, on a 2nd invocation of -->configs, a + ### ::ISA::CACHE package can appear.. that's bad... + my %confs = map { $_ => $_ } + grep { $_ !~ /::ISA::/ } __PACKAGE__->configs; + my @confs = grep { defined } + map { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER; + push @confs, sort keys %confs; + + for my $plugin ( @confs ) { + msg(loc("Found config '%1'", $plugin),0); + + ### if we already did this the /last/ time around dont + ### run the setup agian. + if( my $loc = Module::Loaded::is_loaded( $plugin ) ) { + msg(loc(" Already loaded '%1' (%2)", $plugin, $loc), 0); + next; + } else { + msg(loc(" Loading config '%1'", $plugin),0); + + eval { load $plugin }; + msg(loc(" Loaded '%1' (%2)", + $plugin, Module::Loaded::is_loaded( $plugin ) ), 0); + } + + if( $@ ) { + error(loc("Could not load '%1': %2", $plugin, $@)); + next; + } + + my $sub = $plugin->can('setup'); + $sub->( $self ) if $sub; + } + + ### clean up the paths once more, just in case + $obj->_clean_up_paths; + + return 1; + } +} +=pod + +=head2 can_save( [$config_location] ) + +Check if we can save the configuration to the specified file. +If no file is provided, defaults to your personal config. + +Returns true if the file can be saved, false otherwise. + +=cut + +sub can_save { + my $self = shift; + my $file = shift || CONFIG_USER_FILE->(); + + return 1 unless -e $file; + + chmod 0644, $file; + return (-w $file); +} + +=pod + +=head2 $file = $conf->save( [$package_name] ) + +Saves the configuration to the package name you provided. +If this package is not C, it will +be saved in your C<.cpanplus> directory, otherwise it will +be attempted to be saved in the system wide directory. + +If no argument is provided, it will default to your personal +config. + +Returns the full path to the file if the config was saved, +false otherwise. + +=cut + +sub _config_pm_to_file { + my $self = shift; + my $pm = shift or return; + my $dir = shift || CONFIG_USER_LIB_DIR->(); + + ### only 3 types of files know: home, system and 'other' + ### so figure out where to save them based on their type + my $file; + if( $pm eq CONFIG_USER ) { + $file = CONFIG_USER_FILE->(); + + } elsif ( $pm eq CONFIG_SYSTEM ) { + $file = CONFIG_SYSTEM_FILE->(); + + ### third party file + } else { + my $cfg_pkg = CONFIG . '::'; + unless( $pm =~ /^$cfg_pkg/ ) { + error(loc( + "WARNING: Your config package '%1' is not in the '%2' ". + "namespace and will not be automatically detected by %3", + $pm, $cfg_pkg, 'CPANPLUS' + )); + } + + $file = File::Spec->catfile( + $dir, + split( '::', $pm ) + ) . '.pm'; + } + + return $file; +} + + +sub save { + my $self = shift; + my $pm = shift || CONFIG_USER; + my $savedir = shift || ''; + + my $file = $self->_config_pm_to_file( $pm, $savedir ) or return; + my $dir = dirname( $file ); + + unless( -d $dir ) { + $self->_mkdir( dir => $dir ) or ( + error(loc("Can not create directory '%1' to save config to",$dir)), + return + ) + } + return unless $self->can_save($file); + + ### find only accesors that are not private + my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors; + + ### for dumping the values + use Data::Dumper; + + my @lines; + for my $acc ( @acc ) { + + push @lines, "### $acc section", $/; + + for my $key ( $self->conf->$acc->ls_accessors ) { + my $val = Dumper( $self->conf->$acc->$key ); + + $val =~ s/\$VAR1\s+=\s+//; + $val =~ s/;\n//; + + push @lines, '$'. "conf->set_${acc}( $key => $val );", $/; + } + push @lines, $/,$/; + + } + + my $str = join '', map { " $_" } @lines; + + ### use a variable to make sure the pod parser doesn't snag it + my $is = '='; + my $time = gmtime; + + + my $msg = <<_END_OF_CONFIG_; +############################################### +### +### Configuration structure for $pm +### +############################################### + +#last changed: $time GMT + +### minimal pod, so you can find it with perldoc -l, etc +${is}pod + +${is}head1 NAME + +$pm + +${is}head1 DESCRIPTION + +This is a CPANPLUS configuration file. Editing this +config changes the way CPANPLUS will behave + +${is}cut + +package $pm; + +use strict; + +sub setup { + my \$conf = shift; + +$str + + return 1; +} + +1; + +_END_OF_CONFIG_ + + $self->_move( file => $file, to => "$file~" ) if -f $file; + + my $fh = new FileHandle; + $fh->open(">$file") + or (error(loc("Could not open '%1' for writing: %2", $file, $!)), + return ); + + $fh->print($msg); + $fh->close; + + return $file; +} + +=pod + +=head2 options( type => TYPE ) + +Returns a list of all valid config options given a specific type +(like for example C of C) or false if the type does +not exist + +=cut + +sub options { + my $self = shift; + my $conf = $self->conf; + my %hash = @_; + + my $type; + my $tmpl = { + type => { required => 1, default => '', + strict_type => 1, store => \$type }, + }; + + check($tmpl, \%hash) or return; + + my %seen; + return sort grep { !$seen{$_}++ } + map { $_->$type->ls_accessors if $_->can($type) } + $self->conf; + return; +} + +=pod + +=head1 ACCESSORS + +Accessors that start with a C<_> are marked private -- regular users +should never need to use these. + +=head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] ); + +The C style accessors merely retrieves one or more desired +config options. + +=head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); + +The C style accessors set the current value for one +or more config options and will return true upon success, false on +failure. + +=head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); + +The C style accessor adds a new key to a config key. + +Currently, the following accessors exist: + +=over 4 + +=item set|get_conf + +Simple configuration directives like verbosity and favourite shell. + +=item set|get_program + +Location of helper programs. + +=item _set|_get_build + +Locations of where to put what files for CPANPLUS. + +=item _set|_get_source + +Locations and names of source files locally. + +=item _set|_get_mirror + +Locations and names of source files remotely. + +=item _set|_get_dist + +Mapping of distribution format names to modules. + +=item _set|_get_fetch + +Special settings pertaining to the fetching of files. + +=item _set|_get_daemon + +Settings for C, the CPANPLUS daemon. + +=back + +=cut + +sub AUTOLOAD { + my $self = shift; + my $conf = $self->conf; + + my $name = $AUTOLOAD; + $name =~ s/.+:://; + + my ($private, $action, $field) = + $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/; + + my $type = ''; + $type .= '_' if $private; + $type .= $field if $field; + + unless ( $conf->can($type) ) { + error( loc("Invalid method type: '%1'", $name) ); + return; + } + + unless( scalar @_ ) { + error( loc("No arguments provided!") ); + return; + } + + ### retrieve a current value for an existing key ### + if( $action eq 'get' ) { + for my $key (@_) { + my @list = (); + + ### get it from the user config first + if( $conf->can($type) and $conf->$type->can($key) ) { + push @list, $conf->$type->$key; + + ### XXX EU::AI compatibility hack to provide lookups like in + ### cpanplus 0.04x; we renamed ->_get_build('base') to + ### ->get_conf('base') + } elsif ( $type eq '_build' and $key eq 'base' ) { + return $self->get_conf($key); + + } else { + error( loc(q[No such key '%1' in field '%2'], $key, $type) ); + return; + } + + return wantarray ? @list : $list[0]; + } + + ### set an existing key to a new value ### + } elsif ( $action eq 'set' ) { + my %args = @_; + + while( my($key,$val) = each %args ) { + + if( $conf->can($type) and $conf->$type->can($key) ) { + $conf->$type->$key( $val ); + + } else { + error( loc(q[No such key '%1' in field '%2'], $key, $type) ); + return; + } + } + + return 1; + + ### add a new key to the config ### + } elsif ( $action eq 'add' ) { + my %args = @_; + + while( my($key,$val) = each %args ) { + + if( $conf->$type->can($key) ) { + error( loc( q[Key '%1' already exists for field '%2'], + $key, $type)); + return; + } else { + $conf->$type->mk_accessors( $key ); + $conf->$type->$key( $val ); + } + } + return 1; + + } else { + + error( loc(q[Unknown action '%1'], $action) ); + return; + } +} + +sub DESTROY { 1 }; + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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, L + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/lib/CPANPLUS/Configure/Setup.pm b/lib/CPANPLUS/Configure/Setup.pm new file mode 100644 index 0000000..81ee2ca --- /dev/null +++ b/lib/CPANPLUS/Configure/Setup.pm @@ -0,0 +1,1628 @@ +package CPANPLUS::Configure::Setup; + +use strict; +use vars qw(@ISA); + +use base qw[CPANPLUS::Internals::Utils]; +use base qw[Object::Accessor]; + +use Config; +use Term::UI; +use Module::Load; +use Term::ReadLine; + + +use CPANPLUS::Internals::Utils; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Error; + +use IPC::Cmd qw[can_run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +### silence Term::UI +$Term::UI::VERBOSE = 0; + +#Can't ioctl TIOCGETP: Unknown error +#Consider installing Term::ReadKey from CPAN site nearby +# at http://www.perl.com/CPAN +#Or use +# perl -MCPAN -e shell +#to reach CPAN. Falling back to 'stty'. +# If you do not want to see this warning, set PERL_READLINE_NOWARN +#in your environment. +#'stty' is not recognized as an internal or external command, +#operable program or batch file. +#Cannot call `stty': No such file or directory at C:/Perl/site/lib/Term/ReadLine/ + +### setting this var in the meantime to avoid this warning ### +$ENV{PERL_READLINE_NOWARN} = 1; + + +sub new { + my $class = shift; + my %hash = @_; + + my $tmpl = { + configure_object => { }, + term => { }, + backend => { }, + autoreply => { default => 0, }, + skip_mirrors => { default => 0, }, + use_previous => { default => 1, }, + config_type => { default => CONFIG_USER }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### initialize object + my $obj = $class->SUPER::new( keys %$tmpl ); + for my $acc ( $obj->ls_accessors ) { + $obj->$acc( $args->{$acc} ); + } + + ### otherwise there's a circular use ### + load CPANPLUS::Configure; + load CPANPLUS::Backend; + + $obj->configure_object( CPANPLUS::Configure->new() ) + unless $obj->configure_object; + + $obj->backend( CPANPLUS::Backend->new( $obj->configure_object ) ) + unless $obj->backend; + + ### use empty string in case user only has T::R::Stub -- it complains + $obj->term( Term::ReadLine->new('') ) + unless $obj->term; + + ### enable autoreply if that was passed ### + $Term::UI::AUTOREPLY = $obj->autoreply; + + return $obj; +} + +sub init { + my $self = shift; + my $term = $self->term; + + ### default setting, unless changed + $self->config_type( CONFIG_USER ) unless $self->config_type; + + my $save = loc('Save & exit'); + my $exit = loc('Quit without saving'); + my @map = ( + # key on the display # method to dispatch to + [ loc('Select Configuration file') => '_save_where' ], + [ loc('Setup CLI Programs') => '_setup_program' ], + [ loc('Setup CPANPLUS Home directory') => '_setup_base' ], + [ loc('Setup FTP/Email settings') => '_setup_ftp' ], + [ loc('Setup basic preferences') => '_setup_conf' ], + [ loc('Setup installer settings') => '_setup_installer' ], + [ loc('Select mirrors'), => '_setup_hosts' ], + [ loc('Edit configuration file') => '_edit' ], + [ $save => '_save' ], + [ $exit => 1 ], + ); + + my @keys = map { $_->[0] } @map; # sorted keys + my %map = map { @$_ } @map; # lookup hash + + PICK_SECTION: { + print loc(" +=================> MAIN MENU <================= + +Welcome to the CPANPLUS configuration. Please select which +parts you wish to configure + +Defaults are taken from your current configuration. +If you would save now, your settings would be written to: + + %1 + + ", $self->config_type ); + + my $choice = $term->get_reply( + prompt => "Section to configure:", + choices => \@keys, + default => $keys[0] + ); + + ### exit configuration? + if( $choice eq $exit ) { + print loc(" +Quitting setup, changes will not be saved. + "); + return 1; + } + + my $method = $map{$choice}; + + my $rv = $self->$method or print loc(" +There was an error setting up this section. You might want to try again + "); + + ### was it save & exit? + if( $choice eq $save and $rv ) { + print loc(" +Quitting setup, changes are saved to '%1' + ", $self->config_type + ); + return 1; + } + + ### otherwise, present choice again + redo PICK_SECTION; + } + + return 1; +} + + + +### sub that figures out what kind of config type the user wants +sub _save_where { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + + ASK_CONFIG_TYPE: { + + print loc( q[ +Where would you like to save your CPANPLUS Configuration file? + +If you want to configure CPANPLUS for this user only, +select the '%1' option. +The file will then be saved in your homedirectory. + +If you are the system administrator of this machine, +and would like to make this config available globally, +select the '%2' option. +The file will be then be saved in your CPANPLUS +installation directory. + + ], CONFIG_USER, CONFIG_SYSTEM ); + + + ### ask what config type we should save to + my $type = $term->get_reply( + prompt => loc("Type of configuration file"), + default => $self->config_type || CONFIG_USER, + choices => [CONFIG_USER, CONFIG_SYSTEM], + ); + + my $file = $conf->_config_pm_to_file( $type ); + + ### can we save to this file? + unless( $conf->can_save( $file ) ) { + error(loc( + "Can not save to file '%1'-- please check permissions " . + "and try again", $file + )); + + redo ASK_CONFIG_FILE; + } + + ### you already have the file -- are we allowed to overwrite + ### or should we try again? + if ( -e $file and -w _ ) { + print loc(q[ +I see you already have this file: + %1 + +If you continue & save this file, the previous version will be overwritten. + + ], $file ); + + redo ASK_CONFIG_TYPE + unless $term->ask_yn( + prompt => loc( "Shall I overwrite it?"), + default => 'n', + ); + } + + print $/, loc("Using '%1' as your configuration type", $type); + + return $self->config_type($type); + } +} + + +### setup the build & cache dirs +sub _setup_base { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + my $base = $conf->get_conf('base'); + my $home = File::Spec->catdir( $self->_home_dir, DOT_CPANPLUS ); + + print loc(" +CPANPLUS needs a directory of its own to cache important index +files and maybe keep a temporary mirror of CPAN files. +This may be a site-wide directory or a personal directory. + +For a single-user installation, we suggest using your home directory. + +"); + + my $where; + ASK_HOME_DIR: { + my $other = loc('Somewhere else'); + if( $base and ($base ne $home) ) { + print loc("You have several choices:"); + + $where = $term->get_reply( + prompt => loc('Please pick one'), + choices => [$home, $base, $other], + default => $home, + ); + } else { + $where = $base; + } + + if( $where and -d $where ) { + print loc(" +I see you already have a directory: + %1 + + "), $where; + + my $yn = $term->ask_yn( + prompt => loc('Should I use it?'), + default => 'y', + ); + $where = '' unless $yn; + } + + if( $where and ($where ne $other) and not -d $where ) { + if (!$self->_mkdir( dir => $where ) ) { + print "\n", loc("Unable to create directory '%1'", $where); + redo ASK_HOME_DIR; + } + + } elsif( not $where or ($where eq $other) ) { + print loc(" +First of all, I'd like to create this directory. + + "); + + NEW_HOME: { + $where = $term->get_reply( + prompt => loc('Where shall I create it?'), + default => $home, + ); + + my $again; + if( -d $where and not -w _ ) { + print "\n", loc("I can't seem to write in this directory"); + $again++; + } elsif (!$self->_mkdir( dir => $where ) ) { + print "\n", loc("Unable to create directory '%1'", $where); + $again++; + } + + if( $again ) { + print "\n", loc('Please select another directory'), "\n\n"; + redo NEW_HOME; + } + } + } + } + + ### tidy up the path and store it + $where = File::Spec->rel2abs($where); + $conf->set_conf( base => $where ); + + ### create subdirectories ### + my @dirs = + File::Spec->catdir( $where, $self->_perl_version(perl => $^X), + $conf->_get_build('moddir') ), + map { + File::Spec->catdir( $where, $conf->_get_build($_) ) + } qw[autdir distdir]; + + for my $dir ( @dirs ) { + unless( $self->_mkdir( dir => $dir ) ) { + warn loc("I wasn't able to create '%1'", $dir), "\n"; + } + } + + ### clear away old storable images before 0.031 + for my $src (qw[dslip mailrc packages]) { + 1 while unlink File::Spec->catfile( $where, $src ); + + } + + print loc(q[ +Your CPANPLUS build and cache directory has been set to: + %1 + + ], $where); + + return 1; +} + +sub _setup_ftp { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + ######################### + ## are you a pacifist? ## + ######################### + + print loc(" +If you are connecting through a firewall or proxy that doesn't handle +FTP all that well you can use passive FTP. + +"); + + my $yn = $term->ask_yn( + prompt => loc("Use passive FTP?"), + default => $conf->get_conf('passive'), + ); + + $conf->set_conf(passive => $yn); + + ### set the ENV var as well, else it won't get set till AFTER + ### the configuration is saved. but we fetch files BEFORE that. + $ENV{FTP_PASSIVE} = $yn; + + print "\n"; + print $yn + ? loc("I will use passive FTP.") + : loc("I won't use passive FTP."); + print "\n"; + + ############################# + ## should fetches timeout? ## + ############################# + + print loc(" +CPANPLUS can specify a network timeout for downloads (in whole seconds). +If none is desired (or to skip this question), enter '0'. + +"); + + my $timeout = 0 + $term->get_reply( + prompt => loc("Network timeout for downloads"), + default => $conf->get_conf('timeout') || 0, + allow => qr/(?!\D)/, ### whole numbers only + ); + + $conf->set_conf(timeout => $timeout); + + print "\n"; + print $timeout + ? loc("The network timeout for downloads is %1 seconds.", $timeout) + : loc("The network timeout for downloads is not set."); + print "\n"; + + ############################ + ## where can I reach you? ## + ############################ + + print loc(" +What email address should we send as our anonymous password when +fetching modules from CPAN servers? Some servers will NOT allow you to +connect without a valid email address, or at least something that looks +like one. +Also, if you choose to report test results at some point, a valid email +is required for the 'from' field, so choose wisely. + + "); + + my $other = 'Something else'; + my @choices = (DEFAULT_EMAIL, $Config{cf_email}, $other); + my $current = $conf->get_conf('email'); + + ### if your current address is not in the list, add it to the choices + unless (grep { $_ eq $current } @choices) { + unshift @choices, $current; + } + + my $email = $term->get_reply( + prompt => loc('Which email address shall I use?'), + default => $current || $choices[0], + choices => \@choices, + ); + + if( $email eq $other ) { + EMAIL: { + $email = $term->get_reply( + prompt => loc('Email address: '), + ); + + unless( $self->_valid_email($email) ) { + print loc(" +You did not enter a valid email address, please try again! + ") if length $email; + + redo EMAIL; + } + } + } + + print loc(" +Your 'email' is now: + %1 + + ", $email); + + $conf->set_conf( email => $email ); + + return 1; +} + + +### commandline programs +sub _setup_program { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + print loc(" +CPANPLUS can use command line utilities to do certain +tasks, rather than use perl modules. + +If you wish to use a certain command utility, just enter +the full path (or accept the default). If you do not wish +to use it, enter a single space. + +Note that the paths you provide should not contain spaces, which is +needed to make a distinction between program name and options to that +program. For Win32 machines, you can use the short name for a path, +like '%1'. + + ", 'c:\Progra~1\prog.exe' ); + + for my $prog ( sort $conf->options( type => 'program') ) { + PROGRAM: { + print loc("Where can I find your '%1' utility? ". + "(Enter a single space to disable)", $prog ); + + my $loc = $term->get_reply( + prompt => "Path to your '$prog'", + default => $conf->get_program( $prog ), + ); + + ### empty line clears it + my $cmd = $loc =~ /^\s*$/ ? undef : $loc; + my ($bin) = $cmd =~ /^(\S+)/; + + ### did you provide a valid program ? + if( $bin and not can_run( $bin ) ) { + print "\n"; + print loc("Can not find the binary '%1' in your path!", $bin); + redo PROGRAM; + } + + ### make is special -- we /need/ it! + if( $prog eq 'make' and not $bin ) { + print loc( + "==> Without your '%1' utility, I can not function! <==", + 'make' + ); + print loc("Please provide one!"); + + ### show win32 where to download + if ( $^O eq 'MSWin32' ) { + print loc("You can get '%1' from:", NMAKE); + print "\t". NMAKE_URL ."\n"; + } + print "\n"; + redo PROGRAM; + } + + $conf->set_program( $prog => $cmd ); + print $cmd + ? loc( "Your '%1' utility has been set to '%2'", + $prog, $cmd ) + : loc( "Your '%1' has been disabled", $prog ); + print "\n"; + } + } + + return 1; +} + +sub _setup_installer { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + my $none = 'None'; + { + print loc(" +CPANPLUS uses binary programs as well as Perl modules to accomplish +various tasks. Normally, CPANPLUS will prefer the use of Perl modules +over binary programs. + +You can change this setting by making CPANPLUS prefer the use of +certain binary programs if they are available. + + "); + + ### default to using binaries if we don't have compress::zlib only + ### -- it'll get very noisy otherwise + my $type = 'prefer_bin'; + my $yn = $term->ask_yn( + prompt => loc("Should I prefer the use of binary programs?"), + default => $conf->get_conf( $type ), + ); + + print $yn + ? loc("Ok, I will prefer to use binary programs if possible.") + : loc("Ok, I will prefer to use Perl modules if possible."); + print "\n\n"; + + + $conf->set_conf( $type => $yn ); + } + + { + print loc(" +Makefile.PL is run by perl in a separate process, and accepts various +flags that controls the module's installation. For instance, if you +would like to install modules to your private user directory, set +'makemakerflags' to: + +LIB=~/perl/lib INSTALLMAN1DIR=~/perl/man/man1 INSTALLMAN3DIR=~/perl/man/man3 + +and be sure that you do NOT set UNINST=1 in 'makeflags' below. + +Enter a name=value list separated by whitespace, but quote any embedded +spaces that you want to preserve. (Enter a space to clear any existing +settings.) + +If you don't understand this question, just press ENTER. + + "); + + my $type = 'makemakerflags'; + my $flags = $term->get_reply( + prompt => 'Makefile.PL flags?', + default => $conf->get_conf($type), + ); + + $flags = '' if $flags eq $none || $flags !~ /\S/; + + print "\n", loc("Your '%1' have been set to:", 'Makefile.PL flags'), + "\n ", ( $flags ? $flags : loc('*nothing entered*')), + "\n\n"; + + $conf->set_conf( $type => $flags ); + } + + { + print loc(" +Like Makefile.PL, we run 'make' and 'make install' as separate processes. +If you have any parameters (e.g. '-j3' in dual processor systems) you want +to pass to the calls, please specify them here. + +In particular, 'UNINST=1' is recommended for root users, unless you have +fine-tuned ideas of where modules should be installed in the \@INC path. + +Enter a name=value list separated by whitespace, but quote any embedded +spaces that you want to preserve. (Enter a space to clear any existing +settings.) + +Again, if you don't understand this question, just press ENTER. + + "); + my $type = 'makeflags'; + my $flags = $term->get_reply( + prompt => 'make flags?', + default => $conf->get_conf($type), + ); + + $flags = '' if $flags eq $none || $flags !~ /\S/; + + print "\n", loc("Your '%1' have been set to:", $type), + "\n ", ( $flags ? $flags : loc('*nothing entered*')), + "\n\n"; + + $conf->set_conf( $type => $flags ); + } + + { + print loc(" +An alternative to ExtUtils::MakeMaker and Makefile.PL there's a module +called Module::Build which uses a Build.PL. + +If you would like to specify any flags to pass when executing the +Build.PL (and Build) script, please enter them below. + +For instance, if you would like to install modules to your private +user directory, you could enter: + + install_base=/my/private/path + +Or to uninstall old copies of modules before updating, you might +want to enter: + + uninst=1 + +Again, if you don't understand this question, just press ENTER. + + "); + + my $type = 'buildflags'; + my $flags = $term->get_reply( + prompt => 'Build.PL and Build flags?', + default => $conf->get_conf($type), + ); + + $flags = '' if $flags eq $none || $flags !~ /\S/; + + print "\n", loc("Your '%1' have been set to:", + 'Build.PL and Build flags'), + "\n ", ( $flags ? $flags : loc('*nothing entered*')), + "\n\n"; + + $conf->set_conf( $type => $flags ); + } + + ### use EU::MM or module::build? ### + { + print loc(" +Some modules provide both a Build.PL (Module::Build) and a Makefile.PL +(ExtUtils::MakeMaker). By default, CPANPLUS prefers Makefile.PL. + +Module::Build support is not bundled standard with CPANPLUS, but +requires you to install 'CPANPLUS::Dist::Build' from CPAN. + +Although Module::Build is a pure perl solution, which means you will +not need a 'make' binary, it does have some limitations. The most +important is that CPANPLUS is unable to uninstall any modules installed +by Module::Build. + +Again, if you don't understand this question, just press ENTER. + + "); + my $type = 'prefer_makefile'; + my $yn = $term->ask_yn( + prompt => loc("Prefer Makefile.PL over Build.PL?"), + default => $conf->get_conf($type), + ); + + $conf->set_conf( $type => $yn ); + } + + { + print loc(' +If you like, CPANPLUS can add extra directories to your @INC list during +startup. These will just be used by CPANPLUS and will not change your +external environment or perl interpreter. Enter a space separated list of +pathnames to be added to your @INC, quoting any with embedded whitespace. +(To clear the current value enter a single space.) + + '); + + my $type = 'lib'; + my $flags = $term->get_reply( + prompt => loc('Additional @INC directories to add?'), + default => (join " ", @{$conf->get_conf($type) || []} ), + ); + + my $lib; + unless( $flags =~ /\S/ ) { + $lib = []; + } else { + (@$lib) = $flags =~ m/\s*("[^"]+"|'[^']+'|[^\s]+)/g; + } + + print "\n", loc("Your additional libs are now:"), "\n"; + + print scalar @$lib + ? map { " $_\n" } @$lib + : " ", loc("*nothing entered*"), "\n"; + print "\n\n"; + + $conf->set_conf( $type => $lib ); + } + + return 1; +} + + +sub _setup_conf { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + my $none = 'None'; + { + ############ + ## noisy? ## + ############ + + print loc(" +In normal operation I can just give you basic information about what I +am doing, or I can be more verbose and give you every little detail. + + "); + + my $type = 'verbose'; + my $yn = $term->ask_yn( + prompt => loc("Should I be verbose?"), + default => $conf->get_conf( $type ), ); + + print "\n"; + print $yn + ? loc("You asked for it!") + : loc("I'll try to be quiet"); + + $conf->set_conf( $type => $yn ); + } + + { + ####################### + ## flush you animal! ## + ####################### + + print loc(" +In the interest of speed, we keep track of what modules were installed +successfully and which failed in the current session. We can flush this +data automatically, or you can explicitly issue a 'flush' when you want +to purge it. + + "); + + my $type = 'flush'; + my $yn = $term->ask_yn( + prompt => loc("Flush automatically?"), + default => $conf->get_conf( $type ), + ); + + print "\n"; + print $yn + ? loc("I'll flush after every full module install.") + : loc("I won't flush until you tell me to."); + + $conf->set_conf( $type => $yn ); + } + + { + ##################### + ## force installs? ## + ##################### + + print loc(" +Usually, when a test fails, I won't install the module, but if you +prefer, I can force the install anyway. + + "); + + my $type = 'force'; + my $yn = $term->ask_yn( + prompt => loc("Force installs?"), + default => $conf->get_conf( $type ), + ); + + print "\n"; + print $yn + ? loc("I will force installs.") + : loc("I won't force installs."); + + $conf->set_conf( $type => $yn ); + } + + { + ################### + ## about prereqs ## + ################### + + print loc(" +Sometimes a module will require other modules to be installed before it +will work. CPANPLUS can attempt to install these for you automatically +if you like, or you can do the deed yourself. + +If you would prefer that we NEVER try to install extra modules +automatically, select NO. (Usually you will want this set to YES.) + +If you would like to build modules to satisfy testing or prerequisites, +but not actually install them, select BUILD. + +NOTE: This feature requires you to flush the 'lib' cache for longer +running programs (refer to the CPANPLUS::Backend documentations for +more details). + +Otherwise, select ASK to have us ask your permission to install them. + + "); + + my $type = 'prereqs'; + + my @map = ( + [ PREREQ_IGNORE, # conf value + loc('No, do not install prerequisites'), # UI Value + loc("I won't install prerequisites") # diag message + ], + [ PREREQ_INSTALL, + loc('Yes, please install prerequisites'), + loc("I will install prerequisites") + ], + [ PREREQ_ASK, + loc('Ask me before installing a prerequisite'), + loc("I will ask permission to install") + ], + [ PREREQ_BUILD, + loc('Build prerequisites, but do not install them'), + loc( "I will only build, but not install prerequisites" ) + ], + ); + + my %reply = map { $_->[1] => $_->[0] } @map; # choice => value + my %diag = map { $_->[1] => $_->[2] } @map; # choice => diag message + my %conf = map { $_->[0] => $_->[1] } @map; # value => ui choice + + my $reply = $term->get_reply( + prompt => loc('Follow prerequisites?'), + default => $conf{ $conf->get_conf( $type ) }, + choices => [ @conf{ sort keys %conf } ], + ); + print "\n"; + + my $value = $reply{ $reply }; + my $diag = $diag{ $reply }; + + $conf->set_conf( $type => $value ); + print $diag, "\n"; + } + + { print loc(" +Modules in the CPAN archives are protected with md5 checksums. + +This requires the Perl module Digest::MD5 to be installed (which +CPANPLUS can do for you later); + + "); + my $type = 'md5'; + + my $yn = $term->ask_yn( + prompt => loc("Shall I use the MD5 checksums?"), + default => $conf->get_conf( $type ), + ); + + print $yn + ? loc("I will use the MD5 checksums if you have it") + : loc("I won't use the MD5 checksums"); + + $conf->set_conf( $type => $yn ); + + } + + + { ########################################### + ## sally sells seashells by the seashore ## + ########################################### + + print loc(" +By default CPANPLUS uses its own shell when invoked. If you would prefer +a different shell, such as one you have written or otherwise acquired, +please enter the full name for your shell module. + + "); + + my $type = 'shell'; + my $other = 'Other'; + my @choices = (qw| CPANPLUS::Shell::Default + CPANPLUS::Shell::Classic |, + $other ); + my $default = $conf->get_conf($type); + + unshift @choices, $default unless grep { $_ eq $default } @choices; + + my $reply = $term->get_reply( + prompt => loc('Which CPANPLUS shell do you want to use?'), + default => $default, + choices => \@choices, + ); + + if( $reply eq $other ) { + SHELL: { + $reply = $term->get_reply( + prompt => loc( 'Please enter the name of the shell '. + 'you wish to use: '), + ); + + unless( check_install( module => $reply ) ) { + print "\n", + loc("Could not find '$reply' in your path " . + "-- please try again"), + "\n"; + redo SHELL; + } + } + } + + print "\n", loc("Your shell is now: %1", $reply), "\n\n"; + + $conf->set_conf( $type => $reply ); + } + + { + ################### + ## use storable? ## + ################### + + print loc(" +To speed up the start time of CPANPLUS, and maintain a cache over +multiple runs, we can use Storable to freeze some information. +Would you like to do this? + +"); + my $type = 'storable'; + my $yn = $term->ask_yn( + prompt => loc("Use Storable?"), + default => $conf->get_conf( $type ) ? 1 : 0, + ); + print "\n"; + print $yn + ? loc("I will use Storable if you have it") + : loc("I will not use Storable"); + + $conf->set_conf( $type => $yn ); + } + + { + ################### + ## use cpantest? ## + ################### + + print loc(" +CPANPLUS has support for the Test::Reporter module, which can be utilized +to report success and failures of modules installed by CPANPLUS. Would +you like to do this? Note that you will still be prompted before +sending each report. + +If you don't have all the required modules installed yet, you should +consider installing '%1' + +This package bundles all the required modules to enable test reporting +and querying from CPANPLUS. +You can do so straight after this installation. + + ", 'Bundle::CPANPLUS::Test::Reporter'); + + my $type = 'cpantest'; + my $yn = $term->ask_yn( + prompt => loc('Report test results?'), + default => $conf->get_conf( $type ) ? 1 : 0, + ); + + print "\n"; + print $yn + ? loc("I will prompt you to report test results") + : loc("I won't prompt you to report test results"); + + $conf->set_conf( $type => $yn ); + } + + { + ################################### + ## use cryptographic signatures? ## + ################################### + + print loc(" +The Module::Signature extension allows CPAN authors to sign their +distributions using PGP signatures. Would you like to check for +module's cryptographic integrity before attempting to install them? +Note that this requires either the 'gpg' utility or Crypt::OpenPGP +to be installed. + + "); + my $type = 'signature'; + + my $yn = $term->ask_yn( + prompt => loc('Shall I check module signatures?'), + default => $conf->get_conf($type) ? 1 : 0, + ); + + print "\n"; + print $yn + ? loc("Ok, I will attempt to check module signatures.") + : loc("Ok, I won't attempt to check module signatures."); + + $conf->set_conf( $type => $yn ); + } + + return 1; +} + +sub _setup_hosts { + my $self = shift; + my $term = $self->term; + my $conf = $self->configure_object; + + + if( scalar @{ $conf->get_conf('hosts') } ) { + + my $hosts; + for my $href ( @{$conf->get_conf('hosts')} ) { + $hosts .= "\t$href->{scheme}://$href->{host}$href->{path}\n"; + } + + print loc(" +I see you already have some hosts selected: + +$hosts + +If you'd like to stick with your current settings, just select 'Yes'. +Otherwise, select 'No' and you can reconfigure your hosts + +"); + my $yn = $term->ask_yn( + prompt => loc("Would you like to keep your current hosts?"), + default => 'y', + ); + return 1 if $yn; + } + + my @hosts; + MAIN: { + + print loc(" +Now we need to know where your favorite CPAN sites are located. Make a +list of a few sites (just in case the first on the array won't work). + +If you are mirroring CPAN to your local workstation, specify a file: +URI by picking the CUSTOM option. + +Otherwise, let us fetch the official CPAN mirror list and you can pick +the mirror that suits you best from a list by using the MIRROR option; +First, pick a nearby continent and country. Then, you will be presented +with a list of URLs of CPAN mirrors in the country you selected. Select +one or more of those URLs. + +Note, the latter option requires a working net connection. + +You can select VIEW to see your current selection and QUIT when you +are done. + +"); + + my $reply = $term->get_reply( + prompt => loc('Please choose an option'), + choices => [qw|Mirror Custom View Quit|], + default => 'Mirror', + ); + + goto MIRROR if $reply eq 'Mirror'; + goto CUSTOM if $reply eq 'Custom'; + goto QUIT if $reply eq 'Quit'; + + $self->_view_hosts(@hosts) if $reply eq 'View'; + redo MAIN; + } + + my $mirror_file; + my $hosts; + MIRROR: { + $mirror_file ||= $self->_get_mirrored_by or return; + $hosts ||= $self->_parse_mirrored_by($mirror_file) or return; + + my ($continent, $country, $host) = $self->_guess_from_timezone( $hosts ); + + CONTINENT: { + my %seen; + my @choices = sort map { + $_->{'continent'} + } grep { + not $seen{$_->{'continent'}}++ + } values %$hosts; + push @choices, qw[Custom Up Quit]; + + my $reply = $term->get_reply( + prompt => loc('Pick a continent'), + default => $continent, + choices => \@choices, + ); + + goto MAIN if $reply eq 'Up'; + goto CUSTOM if $reply eq 'Custom'; + goto QUIT if $reply eq 'Quit'; + + $continent = $reply; + } + + COUNTRY: { + my %seen; + my @choices = sort map { + $_->{'country'} + } grep { + not $seen{$_->{'country'}}++ + } grep { + ($_->{'continent'} eq $continent) + } values %$hosts; + push @choices, qw[Custom Up Quit]; + + my $reply = $term->get_reply( + prompt => loc('Pick a country'), + default => $country, + choices => \@choices, + ); + + goto CONTINENT if $reply eq 'Up'; + goto CUSTOM if $reply eq 'Custom'; + goto QUIT if $reply eq 'Quit'; + + $country = $reply; + } + + HOST: { + my @list = grep { + $_->{'continent'} eq $continent and + $_->{'country'} eq $country + } values %$hosts; + + my %map; my $default; + for my $href (@list) { + for my $con ( @{$href->{'connections'}} ) { + next unless length $con->{'host'}; + + my $entry = $con->{'scheme'} . '://' . $con->{'host'}; + $default = $entry if $con->{'host'} eq $host; + + $map{$entry} = $con; + } + } + + CHOICE: { + + ### doesn't play nice with Term::UI :( + ### should make t::ui figure out pager opens + #$self->_pager_open; # host lists might be long + + print loc(" +You can enter multiple sites by seperating them by a space. +For example: + 1 4 2 5 + "); + + my @reply = $term->get_reply( + prompt => loc('Please pick a site: '), + choices => [sort(keys %map), + qw|Custom View Up Quit|], + default => $default, + multi => 1, + ); + #$self->_pager_close; + + + goto COUNTRY if grep { $_ eq 'Up' } @reply; + goto CUSTOM if grep { $_ eq 'Custom' } @reply; + goto QUIT if grep { $_ eq 'Quit' } @reply; + + ### add the host, but only if it's not on the stack already ### + unless( grep { $_ eq 'View' } @reply ) { + for my $reply (@reply) { + if( grep { $_ eq $map{$reply} } @hosts ) { + print loc("Host '%1' already selected", $reply); + print "\n\n"; + } else { + push @hosts, $map{$reply} + } + } + } + + $self->_view_hosts(@hosts); + + goto QUIT if $self->autoreply; + redo CHOICE; + } + } + } + + CUSTOM: { + print loc(" +If there are any additional URLs you would like to use, please add them +now. You may enter them separately or as a space delimited list. + +We provide a default fall-back URL, but you are welcome to override it +with e.g. 'http://www.cpan.org/' if LWP, wget or curl is installed. + +(Enter a single space when you are done, or to simply skip this step.) + +Note that if you want to use a local depository, you will have to enter +as follows: + +file://server/path/to/cpan + +if the file is on a server on your local network or as: + +file:///path/to/cpan + +if the file is on your local disk. Note the three /// after the file: bit + +"); + + CHOICE: { + my $reply = $term->get_reply( + prompt => loc("Additionals host(s) to add: "), + default => '', + ); + + last CHOICE unless $reply =~ /\S/; + + my $href = $self->_parse_host($reply); + + if( $href ) { + push @hosts, $href + unless grep { + $href->{'scheme'} eq $_->{'scheme'} and + $href->{'host'} eq $_->{'host'} and + $href->{'path'} eq $_->{'path'} + } @hosts; + + last CHOICE if $self->autoreply; + } else { + print loc("Invalid uri! Please try again!"); + } + + $self->_view_hosts(@hosts); + + redo CHOICE; + } + + DONE: { + + print loc(" +Where would you like to go now? + +Please pick one of the following options or Quit when you are done + +"); + my $answer = $term->get_reply( + prompt => loc("Where to now?"), + default => 'Quit', + choices => [qw|Mirror Custom View Quit|], + ); + + if( $answer eq 'View' ) { + $self->_view_hosts(@hosts); + redo DONE; + } + + goto MIRROR if $answer eq 'Mirror'; + goto CUSTOM if $answer eq 'Custom'; + goto QUIT if $answer eq 'Quit'; + } + } + + QUIT: { + $conf->set_conf( hosts => \@hosts ); + + print loc(" +Your host configuration has been saved + +"); + } + + return 1; +} + +sub _view_hosts { + my $self = shift; + my @hosts = @_; + + print "\n\n"; + + if( scalar @hosts ) { + my $i = 1; + for my $host (@hosts) { + + ### show full path on file uris, otherwise, just show host + my $path = join '', ( + $host->{'scheme'} eq 'file' + ? ( ($host->{'host'} || '[localhost]'), + $host->{path} ) + : $host->{'host'} + ); + + printf "%-40s %30s\n", + loc("Selected %1",$host->{'scheme'} . '://' . $path ), + loc("%quant(%2,host) selected thus far.", $i); + $i++; + } + } else { + print loc("No hosts selected so far."); + } + + print "\n\n"; + + return 1; +} + +sub _get_mirrored_by { + my $self = shift; + my $cpan = $self->backend; + my $conf = $self->configure_object; + + print loc(" +Now, we are going to fetch the mirror list for first-time configurations. +This may take a while... + +"); + + ### use the enew configuratoin ### + $cpan->configure_object( $conf ); + + load CPANPLUS::Module::Fake; + load CPANPLUS::Module::Author::Fake; + + my $mb = CPANPLUS::Module::Fake->new( + module => $conf->_get_source('hosts'), + path => '', + package => $conf->_get_source('hosts'), + author => CPANPLUS::Module::Author::Fake->new( + _id => $cpan->_id ), + _id => $cpan->_id, + ); + + my $file = $cpan->_fetch( fetchdir => $conf->get_conf('base'), + module => $mb ); + + return $file if $file; + return; +} + +sub _parse_mirrored_by { + my $self = shift; + my $file = shift; + + -s $file or return; + + my $fh = new FileHandle; + $fh->open("$file") + or ( + warn(loc('Could not open file "%1": %2', $file, $!)), + return + ); + + ### slurp the file in ### + { local $/; $file = <$fh> } + + ### remove comments ### + $file =~ s/#.*$//gm; + + $fh->close; + + ### sample host entry ### + # ftp.sun.ac.za: + # frequency = "daily" + # dst_ftp = "ftp://ftp.sun.ac.za/CPAN/CPAN/" + # dst_location = "Stellenbosch, South Africa, Africa (-26.1992 28.0564)" + # dst_organisation = "University of Stellenbosch" + # dst_timezone = "+2" + # dst_contact = "ftpadm@ftp.sun.ac.za" + # dst_src = "ftp.funet.fi" + # + # # dst_dst = "ftp://ftp.sun.ac.za/CPAN/CPAN/" + # # dst_contact = "mailto:ftpadm@ftp.sun.ac.za + # # dst_src = "ftp.funet.fi" + + ### host name as key, rest of the entry as value ### + my %hosts = $file =~ m/([a-zA-Z0-9\-\.]+):\s+((?:\w+\s+=\s+".*?"\s+)+)/gs; + + while (my($host,$data) = each %hosts) { + + my $href; + map { + s/^\s*//; + my @a = split /\s*=\s*/; + $a[1] =~ s/^"(.+?)"$/$1/g; + $href->{ pop @a } = pop @a; + } grep /\S/, split /\n/, $data; + + ($href->{city_area}, $href->{country}, $href->{continent}, + $href->{latitude}, $href->{longitude} ) = + $href->{dst_location} =~ + m/ + #Aizu-Wakamatsu, Tohoku-chiho, Fukushima + ^"?( + (?:[^,]+?)\s* # city + (?: + (?:,\s*[^,]+?)\s* # optional area + )*? # some have multiple areas listed + ) + + #Japan + ,\s*([^,]+?)\s* # country + + #Asia + ,\s*([^,]+?)\s* # continent + + # (37.4333 139.9821) + \((\S+)\s+(\S+?)\)"?$ # (latitude longitude) + /sx; + + ### parse the different hosts, store them in config format ### + my @list; + + for my $type (qw[dst_ftp dst_rsync dst_http]) { + my $path = $href->{$type}; + next unless $path =~ /\w/; + if ($type eq 'dst_rsync' && $path !~ /^rsync:/) { + $path =~ s{::}{/}; + $path = "rsync://$path/"; + } + my $parts = $self->_parse_host($path); + push @list, $parts; + } + + $href->{connections} = \@list; + $hosts{$host} = $href; + } + + return \%hosts; +} + +sub _parse_host { + my $self = shift; + my $host = shift; + + my @parts = $host =~ m|^(\w*)://([^/]*)(/.*)$|s; + + my $href; + for my $key (qw[scheme host path]) { + $href->{$key} = shift @parts; + } + + return if lc($href->{'scheme'}) ne 'file' and !$href->{'host'}; + return if !$href->{'path'}; + + return $href; +} + +## tries to figure out close hosts based on your timezone +## +## Currently can only report on unique items for each of zones, countries, and +## sites. In the future this will be combined with something else (perhaps a +## ping?) to narrow down multiple choices. +## +## Tries to return the best zone, country, and site for your location. Any non- +## unique items will be set to undef instead. +## +## (takes hashref, returns array) +## +sub _guess_from_timezone { + my $self = shift; + my $hosts = shift; + my (%zones, %countries, %sites); + + ### autrijus - build time zone table + my %freq_weight = ( + 'hourly' => 2400, + '4 times a day' => 400, + '4x daily' => 400, + 'daily' => 100, + 'twice daily' => 50, + 'weekly' => 15, + ); + + while (my ($site, $host) = each %{$hosts}) { + my ($zone, $continent, $country, $frequency) = + @{$host}{qw/dst_timezone continent country frequency/}; + + + # skip non-well-formed ones + next unless $continent and $country and $zone =~ /^[-+]?\d+(?::30)?/; + ### fix style + chomp $zone; + $zone =~ s/:30/.5/; + $zone =~ s/^\+//; + $zone =~ s/"//g; + + $zones{$zone}{$continent}++; + $countries{$zone}{$continent}{$country}++; + $sites{$zone}{$continent}{$country}{$site} = $freq_weight{$frequency}; + } + + use Time::Local; + my $offset = ((timegm(localtime) - timegm(gmtime)) / 3600); + + local $_; + + ## pick the entry with most country/site/frequency, one level each; + ## note it has to be sorted -- otherwise we're depending on the hash order. + ## also, the list context assignment (pick first one) is deliberate. + + my ($continent) = map { + (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) + } $zones{$offset}; + + my ($country) = map { + (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) + } $countries{$offset}{$continent}; + + my ($site) = map { + (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) + } $sites{$offset}{$continent}{$country}; + + return ($continent, $country, $site); +} # _guess_from_timezone + + +### big big regex, stolen to check if you enter a valid address +{ + my $RFC822PAT; # RFC pattern to match for valid email address + + sub _valid_email { + my $self = shift; + if (!$RFC822PAT) { + my $esc = '\\\\'; my $Period = '\.'; my $space = '\040'; + my $tab = '\t'; my $OpenBR = '\['; my $CloseBR = '\]'; + my $OpenParen = '\('; my $CloseParen = '\)'; my $NonASCII = '\x80-\xff'; + my $ctrl = '\000-\037'; my $CRlist = '\012\015'; + + my $qtext = qq/[^$esc$NonASCII$CRlist\"]/; + my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/; + my $quoted_pair = qq< $esc [^$NonASCII] >; # an escaped character + my $ctext = qq< [^$esc$NonASCII$CRlist()] >; + my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >; + my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >; + my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >; + my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/; + my $atom = qq< $atom_char+ (?!$atom_char) >; + my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >; + my $word = qq< (?: $atom | $quoted_str ) >; + my $domain_ref = $atom; + my $domain_lit = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >; + my $sub_domain = qq< (?: $domain_ref | $domain_lit) $X >; + my $domain = qq< $sub_domain (?: $Period $X $sub_domain)* >; + my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >; + my $local_part = qq< $word $X (?: $Period $X $word $X )* >; + my $addr_spec = qq< $local_part \@ $X $domain >; + my $route_addr = qq[ < $X (?: $route )? $addr_spec > ]; + my $phrase_ctrl = '\000-\010\012-\037'; # like ctrl, but without tab + my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/; + my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >; + $RFC822PAT = qq< $X (?: $addr_spec | $phrase $route_addr) >; + } + + return scalar ($_[0] =~ /$RFC822PAT/ox); + } +} + + + + + + +1; + + +sub _edit { + my $self = shift; + my $conf = $self->configure_object; + my $file = shift || $conf->_config_pm_to_file( $self->config_type ); + my $editor = shift || $conf->get_program('editor'); + my $term = $self->term; + + unless( $editor ) { + print loc(" +I'm sorry, I can't find a suitable editor, so I can't offer you +post-configuration editing of the config file + +"); + return 1; + } + + ### save the thing first, so there's something to edit + $self->_save; + + return !system("$editor $file"); +} + +sub _save { + my $self = shift; + my $conf = $self->configure_object; + + return $conf->save( $self->config_type ); +} + +1; diff --git a/lib/CPANPLUS/Dist.pm b/lib/CPANPLUS/Dist.pm new file mode 100644 index 0000000..50acb48 --- /dev/null +++ b/lib/CPANPLUS/Dist.pm @@ -0,0 +1,505 @@ +package CPANPLUS::Dist; + +use strict; + + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Object::Accessor; + +local $Params::Check::VERBOSE = 1; + +my @methods = qw[status parent]; +for my $key ( @methods ) { + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + my $self = shift; + $self->{$key} = $_[0] if @_; + return $self->{$key}; + } +} + +=pod + +=head1 NAME + +CPANPLUS::Dist + +=head1 SYNOPSIS + + my $dist = CPANPLUS::Dist->new( + format => 'build', + module => $modobj, + ); + +=head1 DESCRIPTION + +C is a base class for any type of C +modules. + +=head1 ACCESSORS + +=over 4 + +=item parent() + +Returns the C object that parented this object. + +=item status() + +Returns the C object that keeps the status for +this module. + +=back + +=head1 STATUS ACCESSORS + +All accessors can be accessed as follows: + $deb->status->ACCESSOR + +=over 4 + +=item created() + +Boolean indicating whether the dist was created successfully. +Explicitly set to C<0> when failed, so a value of C may be +interpreted as C. + +=item installed() + +Boolean indicating whether the dist was installed successfully. +Explicitly set to C<0> when failed, so a value of C may be +interpreted as C. + +=item uninstalled() + +Boolean indicating whether the dist was uninstalled successfully. +Explicitly set to C<0> when failed, so a value of C may be +interpreted as C. + +=item dist() + +The location of the final distribution. This may be a file or +directory, depending on how your distribution plug in of choice +works. This will be set upon a successful create. + +=cut + +=head2 $dist = CPANPLUS::Dist->new( module => MODOBJ, [format => DIST_TYPE] ); + +Create a new C object based on the provided C. +The optional argument C is used to indicate what type of dist +you would like to create (like C for a C +object, C for a C object, and so on ). +If not provided, will default to the setting as specified by your +config C. + +Returns a C object on success and false on failure. + +=cut + +sub new { + my $self = shift; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + + ### first verify we got a module object ### + my $mod; + my $tmpl = { + module => { required => 1, allow => IS_MODOBJ, store => \$mod }, + }; + check( $tmpl, \%hash ) or return; + + ### get the conf object ### + my $conf = $mod->parent->configure_object(); + + ### figure out what type of dist object to create ### + my $format; + my $tmpl2 = { + format => { default => $conf->get_conf('dist_type'), + allow => [ __PACKAGE__->dist_types ], + store => \$format }, + }; + check( $tmpl2, \%hash ) or return; + + + unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) { + error(loc("'%1' not found -- you need '%2' version '%3' or higher ". + "to detect plugins", $format, 'Module::Pluggable','2.4')); + return; + } + + ### bless the object in the child class ### + my $obj = bless { parent => $mod }, $format; + + ### check if the format is available in this environment ### + if( $conf->_get_build('sanity_check') and not $obj->format_available ) { + error( loc( "Format '%1' is not available",$format) ); + return; + } + + ### create a status object ### + { my $acc = Object::Accessor->new; + $obj->status($acc); + + ### add minimum supported accessors + $acc->mk_accessors( qw[prepared created installed uninstalled + distdir dist] ); + } + + ### now initialize it or admit failure + unless( $obj->init ) { + error(loc("Dist initialization of '%1' failed for '%2'", + $format, $mod->module)); + return; + } + + ### return the object + return $obj; +} + +=head2 @dists = CPANPLUS::Dist->dist_types; + +Returns a list of the CPANPLUS::Dist::* classes available + +=cut + +### returns a list of dist_types we support +### will get overridden by Module::Pluggable if loaded +### XXX add support for 'plugin' dir in config as well +{ my $Loaded; + my @Dists = (INSTALLER_MM); + my @Ignore = (); + + ### backdoor method to add more dist types + sub _add_dist_types { my $self = shift; push @Dists, @_ }; + + ### backdoor method to exclude dist types + sub _ignore_dist_types { my $self = shift; push @Ignore, @_ }; + + ### locally add the plugins dir to @INC, so we can find extra plugins + #local @INC = @INC, File::Spec->catdir( + # $conf->get_conf('base'), + # $conf->_get_build('plugins') ); + + ### load any possible plugins + sub dist_types { + + if ( !$Loaded++ and check_install( module => 'Module::Pluggable', + version => '2.4') + ) { + require Module::Pluggable; + + my $only_re = __PACKAGE__ . '::\w+$'; + + Module::Pluggable->import( + sub_name => '_dist_types', + search_path => __PACKAGE__, + only => qr/$only_re/, + except => [ INSTALLER_MM, + INSTALLER_SAMPLE, + INSTALLER_BASE, + ] + ); + my %ignore = map { $_ => $_ } @Ignore; + + push @Dists, grep { not $ignore{$_} } __PACKAGE__->_dist_types; + } + + return @Dists; + } +} + +=head2 prereq_satisfied( modobj => $modobj, version => $version_spec ) + +Returns true if this prereq is satisfied. Returns false if it's not. +Also issues an error if it seems "unsatisfiable," i.e. if it can't be +found on CPAN or the latest CPAN version doesn't satisfy it. + +=cut + +sub prereq_satisfied { + my $dist = shift; + my $cb = $dist->parent->parent; + my %hash = @_; + + my($mod,$ver); + my $tmpl = { + version => { required => 1, store => \$ver }, + modobj => { required => 1, store => \$mod, allow => IS_MODOBJ }, + }; + + check( $tmpl, \%hash ) or return; + + return 1 if $mod->is_uptodate( version => $ver ); + + if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) { + + error(loc( + "This distribution depends on %1, but the latest version". + " of %2 on CPAN (%3) doesn't satisfy the specific version". + " dependency (%4). You may have to resolve this dependency ". + "manually.", + $mod->module, $mod->module, $mod->version, $ver )); + + } + + return; +} + +=head2 _resolve_prereqs + +Makes sure prerequisites are resolved + +XXX Need docs, internal use only + +=cut + +sub _resolve_prereqs { + my $dist = shift; + my $self = $dist->parent; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my ($prereqs, $format, $verbose, $target, $force, $prereq_build); + my $tmpl = { + ### XXX perhaps this should not be required, since it may not be + ### packaged, just installed... + ### Let it be empty as well -- that means the $modobj->install + ### routine will figure it out, which is fine if we didn't have any + ### very specific wishes (it will even detect the favourite + ### dist_type). + format => { required => 1, store => \$format, + allow => ['',__PACKAGE__->dist_types], }, + prereqs => { required => 1, default => { }, + strict_type => 1, store => \$prereqs }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + force => { default => $conf->get_conf('force'), + store => \$force }, + ### make sure allow matches with $mod->install's list + target => { default => '', store => \$target, + allow => ['',qw[create ignore install]] }, + prereq_build => { default => 0, store => \$prereq_build }, + }; + + check( $tmpl, \%hash ) or return; + + ### so there are no prereqs? then don't even bother + return 1 unless keys %$prereqs; + + ### so you didn't provide an explicit target. + ### maybe your config can tell us what to do. + $target ||= { + PREREQ_ASK, TARGET_INSTALL, # we'll bail out if the user says no + PREREQ_BUILD, TARGET_CREATE, + PREREQ_IGNORE, TARGET_IGNORE, + PREREQ_INSTALL, TARGET_INSTALL, + }->{ $conf->get_conf('prereqs') } || ''; + + ### XXX BIG NASTY HACK XXX FIXME at some point. + ### when installing Bundle::CPANPLUS::Dependencies, we want to + ### install all packages matching 'cpanplus' to be installed last, + ### as all CPANPLUS' prereqs are being installed as well, but are + ### being loaded for bootstrapping purposes. This means CPANPLUS + ### can find them, but for example cpanplus::dist::build won't, + ### which gets messy FAST. So, here we sort our prereqs only IF + ### the parent module is Bundle::CPANPLUS::Dependencies. + ### Really, we would wnat some sort of sorted prereq mechanism, + ### but Bundle:: doesn't support it, and we flatten everything + ### to a hash internally. A sorted hash *might* do the trick if + ### we got a transparent implementation.. that would mean we would + ### just have to remove the 'sort' here, and all will be well + my @sorted_prereqs; + + ### use regex, could either be a module name, or a package name + if( $self->module =~ /^Bundle(::|-)CPANPLUS(::|-)Dependencies/ ) { + my (@first, @last); + for my $mod ( sort keys %$prereqs ) { + $mod =~ /CPANPLUS/ + ? push @last, $mod + : push @first, $mod; + } + @sorted_prereqs = (@first, @last); + } else { + @sorted_prereqs = sort keys %$prereqs; + } + + ### first, transfer this key/value pairing into a + ### list of module objects + desired versions + my @install_me; + + for my $mod ( @sorted_prereqs ) { + my $version = $prereqs->{$mod}; + my $modobj = $cb->module_tree($mod); + + #### XXX we ignore the version, and just assume that the latest + #### version from cpan will meet your requirements... dodgy =/ + unless( $modobj ) { + error( loc( "No such module '%1' found on CPAN", $mod ) ); + next; + } + + ### it's not uptodate, we need to install it + if( !$dist->prereq_satisfied(modobj => $modobj, version => $version)) { + msg(loc("Module '%1' requires '%2' version '%3' to be installed ", + $self->module, $modobj->module, $version), $verbose ); + + push @install_me, [$modobj, $version]; + + ### it's not an MM or Build format, that means it's a package + ### manager... we'll need to install it as well, via the PM + } elsif ( INSTALL_VIA_PACKAGE_MANAGER->($format) and + !$modobj->package_is_perl_core and + ($target ne TARGET_IGNORE) + ) { + msg(loc("Module '%1' depends on '%2', may need to build a '%3' ". + "package for it as well", $self->module, $modobj->module, + $format)); + push @install_me, [$modobj, $version]; + } + } + + + + ### so you just want to ignore prereqs? ### + if( $target eq TARGET_IGNORE ) { + + ### but you have modules you need to install + if( @install_me ) { + msg(loc("Ignoring prereqs, this may mean your install will fail"), + $verbose); + msg(loc("'%1' listed the following dependencies:", $self->module), + $verbose); + + for my $aref (@install_me) { + my ($mod,$version) = @$aref; + + my $str = sprintf "\t%-35s %8s\n", $mod->module, $version; + msg($str,$verbose); + } + + return; + + ### ok, no problem, you have all needed prereqs anyway + } else { + return 1; + } + } + + my $flag; + for my $aref (@install_me) { + my($modobj,$version) = @$aref; + + ### another prereq may have already installed this one... + ### so dont ask again if the module turns out to be uptodate + ### see bug [#11840] + ### if either force or prereq_build are given, the prereq + ### should be built anyway + next if (!$force and !$prereq_build) && + $dist->prereq_satisfied(modobj => $modobj, version => $version); + + ### either we're told to ignore the prereq, + ### or the user wants us to ask him + if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not + $cb->_callbacks->install_prerequisite->($self, $modobj) + ) + ) { + msg(loc("Will not install prerequisite '%1' -- Note " . + "that the overall install may fail due to this", + $modobj->module), $verbose); + next; + } + + ### value set and false -- means failure ### + if( defined $modobj->status->installed + && !$modobj->status->installed + ) { + error( loc( "Prerequisite '%1' failed to install before in " . + "this session", $modobj->module ) ); + $flag++; + last; + } + + ### part of core? + if( $modobj->package_is_perl_core ) { + error(loc("Prerequisite '%1' is perl-core (%2) -- not ". + "installing that. Aborting install", + $modobj->module, $modobj->package ) ); + $flag++; + last; + } + + ### circular dependency code ### + my $pending = $cb->_status->pending_prereqs || {}; + + ### recursive dependency ### + if ( $pending->{ $modobj->module } ) { + error( loc( "Recursive dependency detected (%1) -- skipping", + $modobj->module ) ); + next; + } + + ### register this dependency as pending ### + $pending->{ $modobj->module } = $modobj; + $cb->_status->pending_prereqs( $pending ); + + + ### call $modobj->install rather than doing + ### CPANPLUS::Dist->new and the like ourselves, + ### since ->install will take care of fetch && + ### extract as well + my $pa = $dist->status->_prepare_args || {}; + my $ca = $dist->status->_create_args || {}; + my $ia = $dist->status->_install_args || {}; + + unless( $modobj->install( %$pa, %$ca, %$ia, + force => $force, + verbose => $verbose, + format => $format, + target => $target ) + ) { + error(loc("Failed to install '%1' as prerequisite " . + "for '%2'", $modobj->module, $self->module ) ); + $flag++; + } + + ### unregister the pending dependency ### + $pending->{ $modobj->module } = 0; + $cb->_status->pending_prereqs( $pending ); + + last if $flag; + + ### don't want us to install? ### + if( $target ne TARGET_INSTALL ) { + my $dir = $modobj->status->extract + or error(loc("No extraction dir for '%1' found ". + "-- weird", $modobj->module)); + + $modobj->add_to_includepath(); + + next; + } + } + + ### reset the $prereqs iterator, in case we bailed out early ### + keys %$prereqs; + + return 1 unless $flag; + return; +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Dist/Base.pm b/lib/CPANPLUS/Dist/Base.pm new file mode 100644 index 0000000..2ba0abb --- /dev/null +++ b/lib/CPANPLUS/Dist/Base.pm @@ -0,0 +1,249 @@ +package CPANPLUS::Dist::Base; + +use strict; + +use vars qw[@ISA $VERSION]; +@ISA = qw[CPANPLUS::Dist]; +$VERSION = '0.01'; + +=head1 NAME + +CPANPLUS::Dist::Base - Base class for custom distribution classes + +=head1 SYNOPSIS + + package CPANPLUS::Dist::MY_IMPLEMENTATION + + use base 'CPANPLUS::Dist::Base'; + + sub prepare { + my $dist = shift; + + ### do the 'standard' things + $dist->SUPER::prepare( @_ ) or return; + + ### do MY_IMPLEMENTATION specific things + ... + + ### don't forget to set the status! + return $dist->status->prepared( $SUCCESS ? 1 : 0 ); + } + + +=head1 DESCRIPTION + +CPANPLUS::Dist::Base functions as a base class for all custom +distribution implementations. It does all the mundane work +CPANPLUS would have done without a custom distribution, so you +can override just the parts you need to make your own implementation +work. + +=head1 FLOW + +Below is a brief outline when and in which order methods in this +class are called: + + $Class->format_available; # can we use this class on this system? + + $dist->init; # set up custom accessors, etc + $dist->prepare; # find/write meta information + $dist->create; # write the distribution file + $dist->install; # install the distribution file + + $dist->uninstall; # remove the distribution (OPTIONAL) + +=head1 METHODS + +=cut + + +=head2 $bool = $Class->format_available + +This method is called when someone requests a module to be installed +via the superclass. This gives you the opportunity to check if all +the needed requirements to build and install this distribution have +been met. + +For example, you might need a command line program, or a certain perl +module installed to do your job. Now is the time to check. + +Simply return true if the request can proceed and false if it can not. + +The C implementation always returns true. + +=cut + +sub format_available { return 1 } + + +=head2 $bool = $dist->init + +This method is called just after the new dist object is set up and +before the C method is called. This is the time to set up +the object so it can be used with your class. + +For example, you might want to add extra accessors to the C +object, which you might do as follows: + + $dist->status->mk_accessors( qw[my_implementation_accessor] ); + +The C object is implemented as an instance of the +C class. Please refer to it's documentation for +details. + +Return true if the initialization was successul, and false if it was +not. + +The C implementation does not alter your object +and always returns true. + +=cut + +sub init { return 1; } + +=head2 $bool = $dist->prepare + +This runs the preparation step of your distribution. This step is meant +to set up the environment so the C step can create the actual +distribution(file). +A C call in the standard C distribution +would, for example, run C to find the dependencies +for a distribution. For a C distribution, this is where you +would write all the metafiles required for the C tools. + +The C implementation simply calls the underlying +distribution class (Typically C or +C). + +Sets C<< $dist->status->prepared >> to the return value of this function. +If you override this method, you should make sure to set this value. + +=cut + +sub prepare { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + my $dist_cpan = $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + + $dist->status->prepared( $dist_cpan->prepare( @_ ) ); +} + +=head2 $bool = $dist->create + +This runs the creation step of your distribution. This step is meant +to follow up on the C call, that set up your environment so +the C step can create the actual distribution(file). +A C call in the standard C distribution +would, for example, run C and C to build and test +a distribution. For a C distribution, this is where you +would create the actual C<.deb> file using C. + +The C implementation simply calls the underlying +distribution class (Typically C or +C). + +Sets C<< $dist->status->dist >> to the location of the created +distribution. +If you override this method, you should make sure to set this value. + +Sets C<< $dist->status->created >> to the return value of this function. +If you override this method, you should make sure to set this value. + +=cut + +sub create { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + my $dist_cpan = $self->status->dist_cpan; + $dist = $self->status->dist if $self->status->dist; + $self->status->dist( $dist ) unless $self->status->dist; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + + ### make sure to set this variable, if the caller hasn't yet + ### just so we have some clue where the dist left off. + $dist->status->dist( $dist_cpan->status->distdir ) + unless defined $dist->status->dist; + + $dist->status->created( $dist_cpan->create( @_ ) ); +} + +=head2 $bool = $dist->install + +This runs the install step of your distribution. This step is meant +to follow up on the C call, which prepared a distribution(file) +to install. +A C call in the standard C distribution +would, for example, run C to copy the distribution files +to their final destination. For a C distribution, this is where +you would run C on the created C<.deb> file. + +The C implementation simply calls the underlying +distribution class (Typically C or +C). + +Sets C<< $dist->status->installed >> to the return value of this function. +If you override this method, you should make sure to set this value. + +=cut + +sub install { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + my $dist_cpan = $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + + $dist->status->installed( $dist_cpan->install( @_ ) ); +} + +=head2 $bool = $dist->uninstall + +This runs the uninstall step of your distribution. This step is meant +to remove the distribution from the file system. +A C call in the standard C distribution +would, for example, run C to remove the distribution +files the file system. For a C distribution, this is where you +would run C. + +The C implementation simply calls the underlying +distribution class (Typically C or +C). + +Sets C<< $dist->status->uninstalled >> to the return value of this function. +If you override this method, you should make sure to set this value. + +=cut + +sub uninstall { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + my $dist_cpan = $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + + $dist->status->uninstalled( $dist_cpan->uninstall( @_ ) ); +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Dist/MM.pm b/lib/CPANPLUS/Dist/MM.pm new file mode 100644 index 0000000..f61cfc8 --- /dev/null +++ b/lib/CPANPLUS/Dist/MM.pm @@ -0,0 +1,955 @@ +package CPANPLUS::Dist::MM; + +use strict; +use vars qw[@ISA $STATUS]; +@ISA = qw[CPANPLUS::Dist]; + + +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Constants::Report; +use CPANPLUS::Error; +use FileHandle; +use Cwd; + +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use File::Basename qw[dirname]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Dist::MM + +=head1 SYNOPSIS + + my $mm = CPANPLUS::Dist->new( + format => 'makemaker', + module => $modobj, + ); + $mm->create; # runs make && make test + $mm->install; # runs make install + + +=head1 DESCRIPTION + +C is a distribution class for MakeMaker related +modules. +Using this package, you can create, install and uninstall perl +modules. It inherits from C. + +=head1 ACCESSORS + +=over 4 + +=item parent() + +Returns the C object that parented this object. + +=item status() + +Returns the C object that keeps the status for +this module. + +=back + +=head1 STATUS ACCESSORS + +All accessors can be accessed as follows: + $mm->status->ACCESSOR + +=over 4 + +=item makefile () + +Location of the Makefile (or Build file). +Set to 0 explicitly if something went wrong. + +=item make () + +BOOL indicating if the C (or C) command was successful. + +=item test () + +BOOL indicating if the C (or C) command was +successful. + +=item prepared () + +BOOL indicating if the C call exited succesfully +This gets set after C + +=item distdir () + +Full path to the directory in which the C call took place, +set after a call to C. + +=item created () + +BOOL indicating if the C call exited succesfully. This gets +set after C and C. + +=item installed () + +BOOL indicating if the module was installed. This gets set after +C (or C) exits successfully. + +=item uninstalled () + +BOOL indicating if the module was uninstalled properly. + +=item _create_args () + +Storage of the arguments passed to C for this object. Used +for recursive calls when satisfying prerequisites. + +=item _install_args () + +Storage of the arguments passed to C for this object. Used +for recursive calls when satisfying prerequisites. + +=back + +=cut + +=head1 METHODS + +=head2 $bool = $dist->format_available(); + +Returns a boolean indicating whether or not you can use this package +to create and install modules in your environment. + +=cut + +### check if the format is available ### +sub format_available { + my $dist = shift; + + ### we might be called as $class->format_available =/ + require CPANPLUS::Internals; + my $cb = CPANPLUS::Internals->_retrieve_id( + CPANPLUS::Internals->_last_id ); + my $conf = $cb->configure_object; + + my $mod = "ExtUtils::MakeMaker"; + unless( can_load( modules => { $mod => 0.0 } ) ) { + error( loc( "You do not have '%1' -- '%2' not available", + $mod, __PACKAGE__ ) ); + return; + } + + for my $pgm ( qw[make perlwrapper] ) { + unless( $conf->get_program( $pgm ) ) { + error(loc( + "You do not have '%1' in your path -- '%2' not available\n" . + "Please check your config entry for '%1'", + $pgm, __PACKAGE__ , $pgm + )); + return; + } + } + + return 1; +} + +=pod $bool = $dist->init(); + +Sets up the C object for use. +Effectively creates all the needed status accessors. + +Called automatically whenever you create a new C object. + +=cut + +sub init { + my $dist = shift; + my $status = $dist->status; + + $status->mk_accessors(qw[makefile make test created installed uninstalled + bin_make _prepare_args _create_args _install_args] + ); + + return 1; +} + +=pod $bool = $dist->prepare([perl => '/path/to/perl', makemakerflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL]) + +C preps a distribution for installation. This means it will +run C and determine what prerequisites this distribution +declared. + +If you set C to true, it will go over all the stages of the +C process again, ignoring any previously cached results. + +When running C, the environment variable +C will be set to the full path of the +C that is being executed. This enables any code inside +the C to know that it is being installed via CPANPLUS. + +Returns true on success and false on failure. + +You may then call C<< $dist->create >> on the object to create the +installable files. + +=cut + +sub prepare { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + + ### we're also the cpan_dist, since we don't need to have anything + ### prepared + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + +$DB::single = 1; + my $args; + my( $force, $verbose, $perl, $mmflags ); + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + perl => { default => $^X, store => \$perl }, + makemakerflags => { default => + $conf->get_conf('makemakerflags'), + store => \$mmflags }, + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + ### maybe we already ran a create on this object? ### + return 1 if $dist->status->prepared && !$force; + + ### store the arguments, so ->install can use them in recursive loops ### + $dist->status->_prepare_args( $args ); + + ### chdir to work directory ### + my $orig = cwd(); + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + my $fail; + RUN: { + ### don't run 'perl makefile.pl' again if there's a makefile already + if( -e MAKEFILE->() && (-M MAKEFILE->() < -M $dir) && !$force ) { + msg(loc("'%1' already exists, not running '%2 %3' again ". + " unless you force", + MAKEFILE->(), $perl, MAKEFILE_PL->() ), $verbose ); + + } else { + unless( -e MAKEFILE_PL->() ) { + msg(loc("No '%1' found - attempting to generate one", + MAKEFILE_PL->() ), $verbose ); + + $dist->write_makefile_pl( + verbose => $verbose, + force => $force + ); + + ### bail out if there's no makefile.pl ### + unless( -e MAKEFILE_PL->() ) { + error( loc( "Could not find '%1' - cannot continue", + MAKEFILE_PL->() ) ); + + ### mark that we screwed up ### + $dist->status->makefile(0); + $fail++; last RUN; + } + } + + ### you can turn off running this verbose by changing + ### the config setting below, although it is really not + ### recommended + my $run_verbose = $verbose || + $conf->get_conf('allow_build_interactivity') || + 0; + + ### this makes MakeMaker use defaults if possible, according + ### to schwern. See ticket 8047 for details. + local $ENV{PERL_MM_USE_DEFAULT} = 1 unless $run_verbose; + + ### turn off our PERL5OPT so no modules from CPANPLUS::inc get + ### included in the makefile.pl -- it should build without + ### also, modules that run in taint mode break if we leave + ### our code ref in perl5opt + ### XXX we've removed the ENV settings from cp::inc, so only need + ### to reset the @INC + #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt || ''; + + ### make sure it's a string, so that mmflags that have more than + ### one key value pair are passed as is, rather than as: + ### perl Makefile.PL "key=val key=>val" + + + #### XXX this needs to be the absolute path to the Makefile.PL + ### since cpanp-run-perl uses 'do' to execute the file, and do() + ### checks your @INC.. so, if there's _another_ makefile.pl in + ### your @INC, it will execute that one... + my $makefile_pl = $cb->_safe_path( path => MAKEFILE_PL->( $dir ) ); + + ### setting autoflush to true fixes issue from rt #8047 + ### XXX this means that we need to keep the path to CPANPLUS + ### in @INC, stopping us from resolving dependencies on CPANPLUS + ### at bootstrap time properly. + + ### XXX this fails under ipc::run due to the extra quotes, + ### but it works in ipc::open3. however, ipc::open3 doesn't work + ### on win32/cygwin. XXX TODO get a windows box and sort this out + # my $cmd = qq[$perl -MEnglish -le ] . + # QUOTE_PERL_ONE_LINER->( + # qq[\$OUTPUT_AUTOFLUSH++,do(q($makefile_pl))] + # ) + # . $mmflags; + + # my $flush = OPT_AUTOFLUSH; + # my $cmd = "$perl $flush $makefile_pl $mmflags"; + + my $run_perl = $conf->get_program('perlwrapper'); + my $cmd = "$perl $run_perl $makefile_pl $mmflags"; + + ### set ENV var to tell underlying code this is what we're + ### executing. + my $captured; + my $rv = do { + my $env = ENV_CPANPLUS_IS_EXECUTING; + local $ENV{$env} = $makefile_pl; + scalar run( command => $cmd, + buffer => \$captured, + verbose => $run_verbose, # may be interactive + ); + }; + + unless( $rv ) { + error( loc( "Could not run '%1 %2': %3 -- cannot continue", + $perl, MAKEFILE_PL->(), $captured ) ); + + $dist->status->makefile(0); + $fail++; last RUN; + } + + ### put the output on the stack, don't print it + msg( $captured, 0 ); + } + + ### so, nasty feature in Module::Build, that when a Makefile.PL + ### is a disguised Build.PL, it generates a Build file, not a + ### Makefile. this breaks everything :( see rt bug #19741 + if( not -e MAKEFILE->( $dir ) and -e BUILD_PL->( $dir ) ) { + error(loc( + "We just ran '%1' without errors, but no '%2' is ". + "present. However, there is a '%3' file, so this may ". + "be related to bug #19741 in %4, which describes a ". + "fake '%5' which generates a '%6' file instead of a '%7'. ". + "You could try to work around this issue by setting '%8' ". + "to false and trying again. This will attempt to use the ". + "'%9' instead.", + "$^X ".MAKEFILE_PL->(), MAKEFILE->(), BUILD_PL->(), + 'Module::Build', MAKEFILE_PL->(), 'Build', MAKEFILE->(), + 'prefer_makefile', BUILD_PL->() + )); + + $fail++, last RUN; + } + + ### if we got here, we managed to make a 'makefile' ### + $dist->status->makefile( MAKEFILE->($dir) ); + + ### start resolving prereqs ### + my $prereqs = $self->status->prereqs; + + ### a hashref of prereqs on success, undef on failure ### + $prereqs ||= $dist->_find_prereqs( + verbose => $verbose, + file => $dist->status->makefile + ); + + unless( $prereqs ) { + error( loc( "Unable to scan '%1' for prereqs", + $dist->status->makefile ) ); + + $fail++; last RUN; + } + } + + unless( $cb->_chdir( dir => $orig ) ) { + error( loc( "Could not chdir back to start dir '%1'", $orig ) ); + } + + ### save where we wrote this stuff -- same as extract dir in normal + ### installer circumstances + $dist->status->distdir( $self->status->extract ); + + return $dist->status->prepared( $fail ? 0 : 1); +} + +=pod + +=head2 $href = $dist->_find_prereqs( file => '/path/to/Makefile', [verbose => BOOL]) + +Parses a C for C entries and distills from that +any prerequisites mentioned in the C + +Returns a hash with module-version pairs on success and false on +failure. + +=cut + +sub _find_prereqs { + my $dist = shift; + my $self = $dist->parent; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my ($verbose, $file); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + file => { required => 1, allow => FILE_READABLE, store => \$file }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $fh = FileHandle->new(); + unless( $fh->open( $file ) ) { + error( loc( "Cannot open '%1': %2", $file, $! ) ); + return; + } + + my %p; + while( <$fh> ) { + my ($found) = m|^[\#]\s+PREREQ_PM\s+=>\s+(.+)|; + + next unless $found; + + while( $found =~ m/(?:\s)([\w\:]+)=>(?:q\[(.*?)\],?|undef)/g ) { + if( defined $p{$1} ) { + msg(loc("Warning: PREREQ_PM mentions '%1' more than once. " . + "Last mention wins.", $1 ), $verbose ); + } + + $p{$1} = $cb->_version_to_number(version => $2); + } + last; + } + + my $href = $cb->_callbacks->filter_prereqs->( $cb, \%p ); + + $self->status->prereqs( $href ); + + ### just to make sure it's not the same reference ### + return { %$href }; +} + +=pod + +=head2 $bool = $dist->create([perl => '/path/to/perl', make => '/path/to/make', makeflags => 'EXTRA=FLAGS', prereq_target => TARGET, skiptest => BOOL, force => BOOL, verbose => BOOL]) + +C creates the files necessary for installation. This means +it will run C and C. This will also scan for and +attempt to satisfy any prerequisites the module may have. + +If you set C to true, it will skip the C stage. +If you set C to true, it will go over all the stages of the +C process again, ignoring any previously cached results. It +will also ignore a bad return value from C and still allow +the operation to return true. + +Returns true on success and false on failure. + +You may then call C<< $dist->install >> on the object to actually +install it. + +=cut + +sub create { + ### just in case you already did a create call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + + ### we're also the cpan_dist, since we don't need to have anything + ### prepared + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + my $args; + my( $force, $verbose, $make, $makeflags, $skiptest, $prereq_target, $perl, + $mmflags, $prereq_format, $prereq_build); + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + perl => { default => $^X, store => \$perl }, + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + make => { default => $conf->get_program('make'), + store => \$make }, + makeflags => { default => $conf->get_conf('makeflags'), + store => \$makeflags }, + skiptest => { default => $conf->get_conf('skiptest'), + store => \$skiptest }, + prereq_target => { default => '', store => \$prereq_target }, + ### don't set the default prereq format to 'makemaker' -- wrong! + prereq_format => { #default => $self->status->installer_type, + default => '', + store => \$prereq_format }, + prereq_build => { default => 0, store => \$prereq_build }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + ### maybe we already ran a create on this object? ### + return 1 if $dist->status->created && !$force; + + ### store the arguments, so ->install can use them in recursive loops ### + $dist->status->_create_args( $args ); + + unless( $dist->status->prepared ) { + error( loc( "You have not successfully prepared a '%2' distribution ". + "yet -- cannot create yet", __PACKAGE__ ) ); + return; + } + + + ### chdir to work directory ### + my $orig = cwd(); + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + my $fail; my $prereq_fail; my $test_fail; + RUN: { + ### this will set the directory back to the start + ### dir, so we must chdir /again/ + my $ok = $dist->_resolve_prereqs( + format => $prereq_format, + verbose => $verbose, + prereqs => $self->status->prereqs, + target => $prereq_target, + force => $force, + prereq_build => $prereq_build, + ); + + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + unless( $ok ) { + + #### use $dist->flush to reset the cache ### + error( loc( "Unable to satisfy prerequisites for '%1' " . + "-- aborting install", $self->module ) ); + $dist->status->make(0); + $fail++; $prereq_fail++; + last RUN; + } + ### end of prereq resolving ### + + my $captured; + + ### 'make' section ### + if( -d BLIB->($dir) && (-M BLIB->($dir) < -M $dir) && !$force ) { + msg(loc("Already ran '%1' for this module [%2] -- " . + "not running again unless you force", + $make, $self->module ), $verbose ); + } else { + unless(scalar run( command => [$make, $makeflags], + buffer => \$captured, + verbose => $verbose ) + ) { + error( loc( "MAKE failed: %1 %2", $!, $captured ) ); + $dist->status->make(0); + $fail++; last RUN; + } + + ### put the output on the stack, don't print it + msg( $captured, 0 ); + + $dist->status->make(1); + + ### add this directory to your lib ### + $self->add_to_includepath(); + + ### dont bail out here, there's a conditional later on + #last RUN if $skiptest; + } + + ### 'make test' section ### + unless( $skiptest ) { + + ### turn off our PERL5OPT so no modules from CPANPLUS::inc get + ### included in make test -- it should build without + ### also, modules that run in taint mode break if we leave + ### our code ref in perl5opt + ### XXX CPANPLUS::inc functionality is now obsolete. + #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt || ''; + + ### you can turn off running this verbose by changing + ### the config setting below, although it is really not + ### recommended + my $run_verbose = + $verbose || + $conf->get_conf('allow_build_interactivity') || + 0; + + ### XXX need to add makeflags here too? + ### yes, but they should really be split out -- see bug #4143 + if( scalar run( + command => [$make, 'test', $makeflags], + buffer => \$captured, + verbose => $run_verbose, + ) ) { + ### tests might pass because it doesn't have any tests defined + ### log this occasion non-verbosely, so our test reporter can + ### pick up on this + if ( NO_TESTS_DEFINED->( $captured ) ) { + msg( NO_TESTS_DEFINED->( $captured ), 0 ) + } else { + msg( loc( "MAKE TEST passed: %2", $captured ), $verbose ); + } + + $dist->status->test(1); + } else { + error( loc( "MAKE TEST failed: %1 %2", $!, $captured ) ); + + ### send out error report here? or do so at a higher level? + ### --higher level --kane. + $dist->status->test(0); + + ### mark specifically *test* failure.. so we dont + ### send success on force... + $test_fail++; + + unless( $force ) { + $fail++; last RUN; + } + } + } + } # + + unless( $cb->_chdir( dir => $orig ) ) { + error( loc( "Could not chdir back to start dir '%1'", $orig ) ); + } + + ### send out test report? + ### only do so if the failure is this module, not its prereq + if( $conf->get_conf('cpantest') and not $prereq_fail) { + $cb->_send_report( + module => $self, + failed => $test_fail || $fail, + buffer => CPANPLUS::Error->stack_as_string, + verbose => $verbose, + force => $force, + ) or error(loc("Failed to send test report for '%1'", + $self->module ) ); + } + + return $dist->status->created( $fail ? 0 : 1); +} + +=pod + +=head2 $bool = $dist->install([make => '/path/to/make', makemakerflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL]) + +C runs the following command: + make install + +Returns true on success, false on failure. + +=cut + +sub install { + + ### just in case you did the create with ANOTHER dist object linked + ### to the same module object + my $dist = shift(); + my $self = $dist->parent; + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + + unless( $dist->status->created ) { + error(loc("You have not successfully created a '%2' distribution yet " . + "-- cannot install yet", __PACKAGE__ )); + return; + } + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + my $args; + my($force,$verbose,$make,$makeflags); + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + make => { default => $conf->get_program('make'), + store => \$make }, + makeflags => { default => $conf->get_conf('makeflags'), + store => \$makeflags }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + ### value set and false -- means failure ### + if( defined $self->status->installed && + !$self->status->installed && !$force + ) { + error( loc( "Module '%1' has failed to install before this session " . + "-- aborting install", $self->module ) ); + return; + } + + + $dist->status->_install_args( $args ); + + my $orig = cwd(); + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + my $fail; my $captured; + + ### 'make install' section ### + ### XXX need makeflags here too? + ### yes, but they should really be split out.. see bug #4143 + my $cmd = [$make, 'install', $makeflags]; + my $sudo = $conf->get_program('sudo'); + unshift @$cmd, $sudo if $sudo and $>; + + $cb->flush('lib'); + unless(scalar run( command => $cmd, + verbose => $verbose, + buffer => \$captured, + ) ) { + error( loc( "MAKE INSTALL failed: %1 %2", $!, $captured ) ); + $fail++; + } + + ### put the output on the stack, don't print it + msg( $captured, 0 ); + + unless( $cb->_chdir( dir => $orig ) ) { + error( loc( "Could not chdir back to start dir '%1'", $orig ) ); + } + + return $dist->status->installed( $fail ? 0 : 1 ); + +} + +=pod + +=head2 $bool = $dist->write_makefile_pl([force => BOOL, verbose => BOOL]) + +This routine can write a C from the information in a +module object. It is used to write a C when the original +author forgot it (!!). + +Returns 1 on success and false on failure. + +The file gets written to the directory the module's been extracted +to. + +=cut + +sub write_makefile_pl { + ### just in case you already did a call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + my ($force, $verbose); + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $file = MAKEFILE_PL->($dir); + if( -s $file && !$force ) { + msg(loc("Already created '%1' - not doing so again without force", + $file ), $verbose ); + return 1; + } + + ### due to a bug with AS perl 5.8.4 built 810 (and maybe others) + ### opening files with content in them already does nasty things; + ### seek to pos 0 and then print, but not truncating the file + ### bug reported to activestate on 19 sep 2004: + ### http://bugs.activestate.com/show_bug.cgi?id=34051 + unlink $file if $force; + + my $fh = new FileHandle; + unless( $fh->open( ">$file" ) ) { + error( loc( "Could not create file '%1': %2", $file, $! ) ); + return; + } + + my $mf = MAKEFILE_PL->(); + my $name = $self->module; + my $version = $self->version; + my $author = $self->author->author; + my $href = $self->status->prereqs; + my $prereqs = join ",\n", map { + (' ' x 25) . "'$_'\t=> '$href->{$_}'" + } keys %$href; + $prereqs ||= ''; # just in case there are none; + + print $fh qq| + ### Auto-generated $mf by CPANPLUS ### + + use ExtUtils::MakeMaker; + + WriteMakefile( + NAME => '$name', + VERSION => '$version', + AUTHOR => '$author', + PREREQ_PM => { +$prereqs + }, + ); + \n|; + + $fh->close; + return 1; +} + +sub dist_dir { + ### just in case you already did a call for this module object + ### just via a different dist object + my $dist = shift; + my $self = $dist->parent; + $dist = $self->status->dist_cpan if $self->status->dist_cpan; + $self->status->dist_cpan( $dist ) unless $self->status->dist_cpan; + + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $make; my $verbose; + { local $Params::Check::ALLOW_UNKNOWN = 1; + my $tmpl = { + make => { default => $conf->get_program('make'), + store => \$make }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return; + } + + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc( "No dir found to operate on!" ) ); + return; + } + + ### chdir to work directory ### + my $orig = cwd(); + unless( $cb->_chdir( dir => $dir ) ) { + error( loc( "Could not chdir to build directory '%1'", $dir ) ); + return; + } + + my $fail; my $distdir; + TRY: { + $dist->prepare( @_ ) or (++$fail, last TRY); + + + my $captured; + unless(scalar run( command => [$make, 'distdir'], + buffer => \$captured, + verbose => $verbose ) + ) { + error( loc( "MAKE DISTDIR failed: %1 %2", $!, $captured ) ); + ++$fail, last TRY; + } + + ### /path/to/Foo-Bar-1.2/Foo-Bar-1.2 + $distdir = File::Spec->catdir( $dir, $self->package_name . '-' . + $self->package_version ); + + unless( -d $distdir ) { + error(loc("Do not know where '%1' got created", 'distdir')); + ++$fail, last TRY; + } + } + + unless( $cb->_chdir( dir => $orig ) ) { + error( loc( "Could not chdir to start directory '%1'", $orig ) ); + return; + } + + return if $fail; + return $distdir; +} + + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Dist/Sample.pm b/lib/CPANPLUS/Dist/Sample.pm new file mode 100644 index 0000000..0b09392 --- /dev/null +++ b/lib/CPANPLUS/Dist/Sample.pm @@ -0,0 +1,16 @@ +package CPANPLUS::Dist::Sample; + +=pod + +=head1 NAME + +CPANPLUS::Dist::Sample -- Sample code to create your own Dist::* plugin + +=head1 Description. + +This document is B. Please read the documentation and code +in C. + +=cut + +1; diff --git a/lib/CPANPLUS/Error.pm b/lib/CPANPLUS/Error.pm new file mode 100644 index 0000000..38710a8 --- /dev/null +++ b/lib/CPANPLUS/Error.pm @@ -0,0 +1,201 @@ +package CPANPLUS::Error; + +use strict; + +use Log::Message private => 0;; + +=pod + +=head1 NAME + +CPANPLUS::Error + +=head1 SYNOPSIS + + use CPANPLUS::Error qw[cp_msg cp_error]; + +=head1 DESCRIPTION + +This module provides the error handling code for the CPANPLUS +libraries, and is mainly intended for internal use. + +=head1 FUNCTIONS + +=head2 cp_msg("message string" [,VERBOSE]) + +Records a message on the stack, and prints it to C (or actually +C<$MSG_FH>, see the C section below), if the +C option is true. +The C option defaults to false. + +=head2 msg() + +An alias for C. + +=head2 cp_error("error string" [,VERBOSE]) + +Records an error on the stack, and prints it to C (or actually +C<$ERROR_FH>, see the C sections below), if the +C option is true. +The C options defaults to true. + +=head2 error() + +An alias for C. + +=head1 CLASS METHODS + +=head2 CPANPLUS::Error->stack() + +Retrieves all the items on the stack. Since C is +implemented using C, consult its manpage for the +function C to see what is returned and how to use the items. + +=head2 CPANPLUS::Error->stack_as_string([TRACE]) + +Returns the whole stack as a printable string. If the C option is +true all items are returned with C output, rather than +just the message. +C defaults to false. + +=head2 CPANPLUS::Error->flush() + +Removes all the items from the stack and returns them. Since +C is implemented using C, consult its +manpage for the function C to see what is returned and how +to use the items. + +=cut + +BEGIN { + use Exporter; + use Params::Check qw[check]; + use vars qw[@EXPORT @ISA $ERROR_FH $MSG_FH]; + + @ISA = 'Exporter'; + @EXPORT = qw[cp_error cp_msg error msg]; + + my $log = new Log::Message; + + for my $func ( @EXPORT ) { + no strict 'refs'; + + my $prefix = 'cp_'; + my $name = $func; + $name =~ s/^$prefix//g; + + *$func = sub { + my $msg = shift; + + ### no point storing non-messages + return unless defined $msg; + + $log->store( + message => $msg, + tag => uc $name, + level => $prefix . $name, + extra => [@_] + ); + }; + } + + sub flush { + return reverse $log->flush; + } + + sub stack { + return $log->retrieve( chrono => 1 ); + } + + sub stack_as_string { + my $class = shift; + my $trace = shift() ? 1 : 0; + + return join $/, map { + '[' . $_->tag . '] [' . $_->when . '] ' . + ($trace ? $_->message . ' ' . $_->longmess + : $_->message); + } __PACKAGE__->stack; + } +} + +=head1 GLOBAL VARIABLES + +=over 4 + +=item $ERROR_FH + +This is the filehandle all the messages sent to C are being +printed. This defaults to C<*STDERR>. + +=item $MSG_FH + +This is the filehandle all the messages sent to C are being +printed. This default to C<*STDOUT>. + +=cut +local $| = 1; +$ERROR_FH = \*STDERR; +$MSG_FH = \*STDOUT; + +package Log::Message::Handlers; +use Carp (); + +{ + + sub cp_msg { + my $self = shift; + my $verbose = shift; + + ### so you don't want us to print the msg? ### + return if defined $verbose && $verbose == 0; + + my $old_fh = select $CPANPLUS::Error::MSG_FH; + + print '['. $self->tag . '] ' . $self->message . "\n"; + select $old_fh; + + return; + } + + sub cp_error { + my $self = shift; + my $verbose = shift; + + ### so you don't want us to print the error? ### + return if defined $verbose && $verbose == 0; + + my $old_fh = select $CPANPLUS::Error::ERROR_FH; + + ### is only going to be 1 for now anyway ### + ### C::I may not be loaded, so do a can() check first + my $cb = CPANPLUS::Internals->can('_return_all_objects') + ? (CPANPLUS::Internals->_return_all_objects)[0] + : undef; + + ### maybe we didn't initialize an internals object (yet) ### + my $debug = $cb ? $cb->configure_object->get_conf('debug') : 0; + my $msg = '['. $self->tag . '] ' . $self->message . "\n"; + + ### i'm getting this warning in the test suite: + ### Ambiguous call resolved as CORE::warn(), qualify as such or + ### use & at CPANPLUS/Error.pm line 57. + ### no idea where it's coming from, since there's no 'sub warn' + ### anywhere to be found, but i'll mark it explicitly nonetheless + ### --kane + print $debug ? Carp::shortmess($msg) : $msg . "\n"; + + select $old_fh; + + return; + } +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/FAQ.pod b/lib/CPANPLUS/FAQ.pod new file mode 100644 index 0000000..82bb57a --- /dev/null +++ b/lib/CPANPLUS/FAQ.pod @@ -0,0 +1,30 @@ +=pod + +=head1 NAME + +CPANPLUS::FAQ + +=head1 DESCRIPTION + +This document attempts to provide answers to commonly asked questions. + + XXX Work in progress + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + diff --git a/lib/CPANPLUS/Hacking.pod b/lib/CPANPLUS/Hacking.pod new file mode 100644 index 0000000..c89a403 --- /dev/null +++ b/lib/CPANPLUS/Hacking.pod @@ -0,0 +1,142 @@ +=pod + +=head1 NAME + +CPANPLUS::Hacking + +=head1 DESCRIPTION + +This document attempts to describe how to easiest develop with the +CPANPLUS environment, how certain things work and why. + +This is basically a quick-start guide to people who want to add +features or patches to CPANPLUS. + +=head1 OBTAINING CPANPLUS + +CPANPLUS offers snapshots from the stable and unstable branches. +After every patch to either of the branches, the snapshot is +automatically updated. + +You can find the stable branch here (which should be equal to the +CPAN release): L + +And the development branch here: +L + +=head1 INSTALLING CPANPLUS + +CPANPLUS follows the standard perl module installation process: + + perl Makefile.PL + make + make test + make install + +=head1 CONFIGURING CPANPLUS + +When running C you will be prompted to configure. +If you have already done so, and merely wish to update the C, +simply run: + + perl Makefile.PL JFDI=1 + +This will keep your configuration intact. Note however, if there are +changes to the default configuration file C, you should +either delete your current config file and reconfigure, or patch your +config file from the new entries in C. + +=head1 RUNNING CPANPLUS FROM DEVELOPMENT ENVIRONMENT + +If you'd rather not install the development version to your +C directory, that's no problem. You can set your C +environment variable to CPANPLUS' C directory, and you can run it +from there. + +=head1 RUNNING CPANPLUS TESTS + +Tests are what tells us if CPANPLUS is working. If a test is not working, +try to run it explicilty like this: + + perl -I/path/to/cpanplus/lib t/XX_name_of_test.t 1 + +The extra '1' makes sure that all the messages and errors (they might +be errors we're testing for!) are being printed rather than kept quiet. +This is a great way to find out the context of any failures that may +occur. + +If you believe this test failure proves a bug in CPANPLUS, the long +output of the test file is something we'd like to see alongside your +bug report. + +=head1 FINDING BUGS + +Sometimes you might find bugs in CPANPLUS' behaviour. If you encounter +these in a development snapshot, we'd appreciate a complete patch (as +described below in the L section. + +If it's way over your head, then of course reporting the bug is always +better than not reporting it at all. Before you do so though, make +sure you have the B development snapshot, and the bug still +persists there. If so, report the bug to this address: + + cpanplus-devel@lists.sourceforge.net + +A good C would have the following characteristics: + +=over 4 + +=item Problem description + +Describe clearly what the bug is you found, and what it should have +done instead. + +=item Program demonstrating the bug + +Show us how to reproduce the bug, in a simple of a program as possible + +=item [OPTIONAL] A patch to the test suite to test for the bug + +Amend our test suite by making sure this bug will be found in this, and +future versions of CPANPLUS (see L) + +=item [OPTIONAL] A patch to the code + tests + documentation + +Fix the bug, update the docs & tests. That way your bug will be gone +forever :) + +=back + +=head1 SUPPLYING PATCHES + +Patches are a good thing, and they are welcome. Especially if they fix +bugs you've found along the way, or that others have reported. + +We prefer patches in the following format: + +=over 4 + +=item * In C or C format + +=item * From the root of the snapshot + +=item * Including patches for code + tests + docs + +=item * Sent per mail to cpanplus-devel@lists.sourceforge.net + +=item * With subject containing C<[PATCH]> + description of the patch + +=back + +You will always be informed if a patch is applied or rejected, and in +case of rejection why that is (perhaps you can tweak the patch to have +it accepted after all). + +=cut + +__END__ + +* perl5lib +* perl t/foo 1 +* patches to cpanplus-devel +* snap/devel.tgz diff --git a/lib/CPANPLUS/Internals.pm b/lib/CPANPLUS/Internals.pm new file mode 100644 index 0000000..0ba2529 --- /dev/null +++ b/lib/CPANPLUS/Internals.pm @@ -0,0 +1,489 @@ +package CPANPLUS::Internals; + +### we /need/ perl5.6.1 or higher -- we use coderefs in @INC, +### and 5.6.0 is just too buggy +use 5.006001; + +use strict; +use Config; + + +use CPANPLUS::Error; + +use CPANPLUS::Selfupdate; + +use CPANPLUS::Internals::Source; +use CPANPLUS::Internals::Extract; +use CPANPLUS::Internals::Fetch; +use CPANPLUS::Internals::Utils; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Search; +use CPANPLUS::Internals::Report; + +use Cwd qw[cwd]; +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use Object::Accessor; + + +local $Params::Check::VERBOSE = 1; + +use vars qw[@ISA $VERSION]; + +@ISA = qw[ + CPANPLUS::Internals::Source + CPANPLUS::Internals::Extract + CPANPLUS::Internals::Fetch + CPANPLUS::Internals::Utils + CPANPLUS::Internals::Search + CPANPLUS::Internals::Report + ]; + +$VERSION = "0.78"; + +=pod + +=head1 NAME + +CPANPLUS::Internals + +=head1 SYNOPSIS + + my $internals = CPANPLUS::Internals->_init( _conf => $conf ); + my $backend = CPANPLUS::Internals->_retrieve_id( $ID ); + +=head1 DESCRIPTION + +This module is the guts of CPANPLUS -- it inherits from all other +modules in the CPANPLUS::Internals::* namespace, thus defying normal +rules of OO programming -- but if you're reading this, you already +know what's going on ;) + +Please read the C documentation for the normal API. + +=head1 ACCESSORS + +=over 4 + +=item _conf + +Get/set the configure object + +=item _id + +Get/set the id + +=item _lib + +Get/set the current @INC path -- @INC is reset to this after each +install. + +=item _perl5lib + +Get/set the current PERL5LIB environment variable -- $ENV{PERL5LIB} +is reset to this after each install. + +=cut + +### autogenerate accessors ### +for my $key ( qw[_conf _id _lib _perl5lib _modules _hosts _methods _status + _callbacks _selfupdate] +) { + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + $_[0]->{$key} = $_[1] if @_ > 1; + return $_[0]->{$key}; + } +} + +=pod + +=head1 METHODS + +=head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ ) + +C<_init> creates a new CPANPLUS::Internals object. + +You have to pass it a valid C object. + +Returns the object on success, or dies on failure. + +=cut +{ ### NOTE: + ### if extra callbacks are added, don't forget to update the + ### 02-internals.t test script with them! + my $callback_map = { + ### name default value + install_prerequisite => 1, # install prereqs when 'ask' is set? + edit_test_report => 0, # edit the prepared test report? + send_test_report => 1, # send the test report? + # munge the test report + munge_test_report => sub { return $_[1] }, + # filter out unwanted prereqs + filter_prereqs => sub { return $_[1] }, + }; + + my $status = Object::Accessor->new; + $status->mk_accessors(qw[pending_prereqs]); + + my $callback = Object::Accessor->new; + $callback->mk_accessors(keys %$callback_map); + + my $conf; + my $Tmpl = { + _conf => { required => 1, store => \$conf, + allow => IS_CONFOBJ }, + _id => { default => '', no_override => 1 }, + _lib => { default => [ @INC ], no_override => 1 }, + _perl5lib => { default => $ENV{'PERL5LIB'}, no_override => 1 }, + _authortree => { default => '', no_override => 1 }, + _modtree => { default => '', no_override => 1 }, + _hosts => { default => {}, no_override => 1 }, + _methods => { default => {}, no_override => 1 }, + _status => { default => '', no_override => 1 }, + _callbacks => { default => '', no_override => 1 }, + }; + + sub _init { + my $class = shift; + my %hash = @_; + + ### temporary warning until we fix the storing of multiple id's + ### and their serialization: + ### probably not going to happen --kane + if( my $id = $class->_last_id ) { + # make it a singleton. + warn loc(q[%1 currently only supports one %2 object per ] . + q[running program], 'CPANPLUS', $class); + + return $class->_retrieve_id( $id ); + } + + my $args = check($Tmpl, \%hash) + or die loc(qq[Could not initialize '%1' object], $class); + + bless $args, $class; + + $args->{'_id'} = $args->_inc_id; + $args->{'_status'} = $status; + $args->{'_callbacks'} = $callback; + + ### initialize callbacks to default state ### + for my $name ( $callback->ls_accessors ) { + my $rv = ref $callback_map->{$name} ? 'sub return value' : + $callback_map->{$name} ? 'true' : 'false'; + + $args->_callbacks->$name( + sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'", + $name, $rv), $args->_conf->get_conf('debug')); + return ref $callback_map->{$name} + ? $callback_map->{$name}->( @_ ) + : $callback_map->{$name}; + } + ); + } + + ### create a selfupdate object + $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) ); + + ### initalize it as an empty hashref ### + $args->_status->pending_prereqs( {} ); + + ### allow for dirs to be added to @INC at runtime, + ### rather then compile time + push @INC, @{$conf->get_conf('lib')}; + + ### add any possible new dirs ### + $args->_lib( [@INC] ); + + $conf->_set_build( startdir => cwd() ), + or error( loc("couldn't locate current dir!") ); + + $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive'); + + my $id = $args->_store_id( $args ); + + unless ( $id == $args->_id ) { + error( loc("IDs do not match: %1 != %2. Storage failed!", + $id, $args->_id) ); + } + + return $args; + } + +=pod + +=head2 $bool = $internals->_flush( list => \@caches ) + +Flushes the designated caches from the C object. + +Returns true on success, false if one or more caches could not be +be flushed. + +=cut + + sub _flush { + my $self = shift; + my %hash = @_; + + my $aref; + my $tmpl = { + list => { required => 1, default => [], + strict_type => 1, store => \$aref }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $flag = 0; + for my $what (@$aref) { + my $cache = '_' . $what; + + ### set the include paths back to their original ### + if( $what eq 'lib' ) { + $ENV{PERL5LIB} = $self->_perl5lib || ''; + @INC = @{$self->_lib}; + + ### give all modules a new status object -- this is slightly + ### costly, but the best way to make sure all statusses are + ### forgotten --kane + } elsif ( $what eq 'modules' ) { + for my $modobj ( values %{$self->module_tree} ) { + $modobj->_flush; + } + + ### blow away the methods cache... currently, that's only + ### File::Fetch's method fail list + } elsif ( $what eq 'methods' ) { + + ### still fucking p4 :( ### + $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {}; + + ### blow away the m::l::c cache, so modules can be (re)loaded + ### again if they become available + } elsif ( $what eq 'load' ) { + undef $Module::Load::Conditional::CACHE; + + } else { + unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) { + error( loc( "No such cache: '%1'", $what ) ); + $flag++; + next; + } else { + $self->$cache( {} ); + } + } + } + return !$flag; + } + +### NOTE: +### if extra callbacks are added, don't forget to update the +### 02-internals.t test script with them! + +=pod + +=head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF ); + +Registers a callback for later use by the internal libraries. + +Here is a list of the currently used callbacks: + +=over 4 + +=item install_prerequisite + +Is called when the user wants to be C about what to do with +prerequisites. Should return a boolean indicating true to install +the prerequisite and false to skip it. + +=item send_test_report + +Is called when the user should be prompted if he wishes to send the +test report. Should return a boolean indicating true to send the +test report and false to skip it. + +=item munge_test_report + +Is called when the test report message has been composed, giving +the user a chance to programatically alter it. Should return the +(munged) message to be sent. + +=item edit_test_report + +Is called when the user should be prompted to edit test reports +about to be sent out by Test::Reporter. Should return a boolean +indicating true to edit the test report in an editor and false +to skip it. + +=back + +=cut + + sub _register_callback { + my $self = shift or return; + my %hash = @_; + + my ($name,$code); + my $tmpl = { + name => { required => 1, store => \$name, + allow => [$callback->ls_accessors] }, + code => { required => 1, allow => IS_CODEREF, + store => \$code }, + }; + + check( $tmpl, \%hash ) or return; + + $self->_callbacks->$name( $code ) or return; + + return 1; + } + +# =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF ); +# +# Adds a new callback to be used from anywhere in the system. If the callback +# is already known, an error is raised and false is returned. If the callback +# is not yet known, it is added, and the corresponding coderef is registered +# using the +# +# =cut +# +# sub _add_callback { +# my $self = shift or return; +# my %hash = @_; +# +# my ($name,$code); +# my $tmpl = { +# name => { required => 1, store => \$name, }, +# code => { required => 1, allow => IS_CODEREF, +# store => \$code }, +# }; +# +# check( $tmpl, \%hash ) or return; +# +# if( $callback->can( $name ) ) { +# error(loc("Callback '%1' is already registered")); +# return; +# } +# +# $callback->mk_accessor( $name ); +# +# $self->_register_callback( name => $name, code => $code ) or return; +# +# return 1; +# } + +} + +=pod + +=head2 $bool = $internals->_add_to_includepath( directories => \@dirs ) + +Adds a list of directories to the include path. +This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>. + +Returns true on success, false on failure. + +=cut + +sub _add_to_includepath { + my $self = shift; + my %hash = @_; + + my $dirs; + my $tmpl = { + directories => { required => 1, default => [], store => \$dirs, + strict_type => 1 }, + }; + + check( $tmpl, \%hash ) or return; + + for my $lib (@$dirs) { + push @INC, $lib unless grep { $_ eq $lib } @INC; + } + + { local $^W; ### it will be complaining if $ENV{PERL5LIB] + ### is not defined (yet). + $ENV{'PERL5LIB'} .= join '', map { $Config{'path_sep'} . $_ } @$dirs; + } + + return 1; +} + +=pod + +=head2 $id = CPANPLUS::Internals->_last_id + +Return the id of the last object stored. + +=head2 $id = CPANPLUS::Internals->_store_id( $internals ) + +Store this object; return its id. + +=head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID ) + +Retrieve an object based on its ID -- return false on error. + +=head2 CPANPLUS::Internals->_remove_id( $ID ) + +Remove the object marked by $ID from storage. + +=head2 @objs = CPANPLUS::Internals->_return_all_objects + +Return all stored objects. + +=cut + + +### code for storing multiple objects +### -- although we only support one right now +### XXX when support for multiple objects comes, saving source will have +### to change +{ + my $idref = {}; + my $count = 0; + + sub _inc_id { return ++$count; } + + sub _last_id { $count } + + sub _store_id { + my $self = shift; + my $obj = shift or return; + + unless( IS_INTERNALS_OBJ->($obj) ) { + error( loc("The object you passed has the wrong ref type: '%1'", + ref $obj) ); + return; + } + + $idref->{ $obj->_id } = $obj; + return $obj->_id; + } + + sub _retrieve_id { + my $self = shift; + my $id = shift or return; + + my $obj = $idref->{$id}; + return $obj; + } + + sub _remove_id { + my $self = shift; + my $id = shift or return; + + return delete $idref->{$id}; + } + + sub _return_all_objects { return values %$idref } +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Constants.pm b/lib/CPANPLUS/Internals/Constants.pm new file mode 100644 index 0000000..0961e25 --- /dev/null +++ b/lib/CPANPLUS/Internals/Constants.pm @@ -0,0 +1,302 @@ +package CPANPLUS::Internals::Constants; + +use strict; + +use CPANPLUS::Error; + +use File::Spec; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +require Exporter; +use vars qw[$VERSION @ISA @EXPORT]; + +use Package::Constants; + + +$VERSION = 0.01; +@ISA = qw[Exporter]; +@EXPORT = Package::Constants->list( __PACKAGE__ ); + + +sub constants { @EXPORT }; + +use constant INSTALLER_BUILD + => 'CPANPLUS::Dist::Build'; +use constant INSTALLER_MM => 'CPANPLUS::Dist::MM'; +use constant INSTALLER_SAMPLE + => 'CPANPLUS::Dist::Sample'; +use constant INSTALLER_BASE => 'CPANPLUS::Dist::Base'; + +use constant CONFIG => 'CPANPLUS::Config'; +use constant CONFIG_USER => 'CPANPLUS::Config::User'; +use constant CONFIG_SYSTEM => 'CPANPLUS::Config::System'; + +use constant TARGET_CREATE => 'create'; +use constant TARGET_PREPARE => 'prepare'; +use constant TARGET_INSTALL => 'install'; +use constant TARGET_IGNORE => 'ignore'; +use constant DOT_CPANPLUS => $^O eq 'VMS' ? '_cpanplus' : '.cpanplus'; + +use constant OPT_AUTOFLUSH => '-MCPANPLUS::Internals::Utils::Autoflush'; + +use constant UNKNOWN_DL_LOCATION + => 'UNKNOWN-ORIGIN'; + +use constant NMAKE => 'nmake.exe'; +use constant NMAKE_URL => + 'ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe'; + +use constant INSTALL_VIA_PACKAGE_MANAGER + => sub { my $fmt = $_[0] or return; + return 1 if $fmt ne INSTALLER_BUILD and + $fmt ne INSTALLER_MM; + }; + +use constant IS_CODEREF => sub { ref $_[-1] eq 'CODE' }; +use constant IS_MODOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module') }; +use constant IS_FAKE_MODOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module::Fake') }; +use constant IS_AUTHOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module::Author') }; +use constant IS_FAKE_AUTHOBJ + => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Module::Author::Fake') }; + +use constant IS_CONFOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Configure') }; + +use constant IS_RVOBJ => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Backend::RV') }; + +use constant IS_INTERNALS_OBJ + => sub { UNIVERSAL::isa($_[-1], + 'CPANPLUS::Internals') }; + +use constant IS_FILE => sub { return 1 if -e $_[-1] }; + +use constant FILE_EXISTS => sub { + my $file = $_[-1]; + return 1 if IS_FILE->($file); + local $Carp::CarpLevel = + $Carp::CarpLevel+2; + error(loc( q[File '%1' does not exist], + $file)); + return; + }; + +use constant FILE_READABLE => sub { + my $file = $_[-1]; + return 1 if -e $file && -r _; + local $Carp::CarpLevel = + $Carp::CarpLevel+2; + error( loc( q[File '%1' is not readable ]. + q[or does not exist], $file)); + return; + }; +use constant IS_DIR => sub { return 1 if -d $_[-1] }; + +use constant DIR_EXISTS => sub { + my $dir = $_[-1]; + return 1 if IS_DIR->($dir); + local $Carp::CarpLevel = + $Carp::CarpLevel+2; + error(loc(q[Dir '%1' does not exist], + $dir)); + return; + }; + +use constant MAKEFILE_PL => sub { return @_ + ? File::Spec->catfile( @_, + 'Makefile.PL' ) + : 'Makefile.PL'; + }; +use constant MAKEFILE => sub { return @_ + ? File::Spec->catfile( @_, + 'Makefile' ) + : 'Makefile'; + }; +use constant BUILD_PL => sub { return @_ + ? File::Spec->catfile( @_, + 'Build.PL' ) + : 'Build.PL'; + }; + +use constant BLIB => sub { return @_ + ? File::Spec->catfile(@_, 'blib') + : 'blib'; + }; + +use constant LIB => 'lib'; +use constant LIB_DIR => sub { return @_ + ? File::Spec->catdir(@_, LIB) + : LIB; + }; +use constant AUTO => 'auto'; +use constant LIB_AUTO_DIR => sub { return @_ + ? File::Spec->catdir(@_, LIB, AUTO) + : File::Spec->catdir(LIB, AUTO) + }; +use constant ARCH => 'arch'; +use constant ARCH_DIR => sub { return @_ + ? File::Spec->catdir(@_, ARCH) + : ARCH; + }; +use constant ARCH_AUTO_DIR => sub { return @_ + ? File::Spec->catdir(@_,ARCH,AUTO) + : File::Spec->catdir(ARCH,AUTO) + }; + +use constant BLIB_LIBDIR => sub { return @_ + ? File::Spec->catdir( + @_, BLIB->(), LIB ) + : File::Spec->catdir( BLIB->(), LIB ); + }; + +use constant CONFIG_USER_LIB_DIR => sub { + require CPANPLUS::Internals::Utils; + LIB_DIR->( + CPANPLUS::Internals::Utils->_home_dir, + DOT_CPANPLUS + ); + }; +use constant CONFIG_USER_FILE => sub { + File::Spec->catfile( + CONFIG_USER_LIB_DIR->(), + split('::', CONFIG_USER), + ) . '.pm'; + }; +use constant CONFIG_SYSTEM_FILE => sub { + require CPANPLUS::Internals; + require File::Basename; + my $dir = File::Basename::dirname( + $INC{'CPANPLUS/Internals.pm'} + ); + + ### XXX use constants + File::Spec->catfile( + $dir, qw[Config System.pm] + ); + }; + +use constant README => sub { my $obj = $_[0]; + my $pkg = $obj->package_name; + $pkg .= '-' . $obj->package_version . + '.readme'; + return $pkg; + }; +use constant OPEN_FILE => sub { + my($file, $mode) = (@_, ''); + my $fh; + open $fh, "$mode" . $file + or error(loc( + "Could not open file '%1': %2", + $file, $!)); + return $fh if $fh; + return; + }; + +use constant STRIP_GZ_SUFFIX + => sub { + my $file = $_[0] or return; + $file =~ s/.gz$//i; + return $file; + }; + +use constant CHECKSUMS => 'CHECKSUMS'; +use constant PGP_HEADER => '-----BEGIN PGP SIGNED MESSAGE-----'; +use constant ENV_CPANPLUS_CONFIG + => 'PERL5_CPANPLUS_CONFIG'; +use constant ENV_CPANPLUS_IS_EXECUTING + => 'PERL5_CPANPLUS_IS_EXECUTING'; +use constant DEFAULT_EMAIL => 'cpanplus@example.com'; +use constant CPANPLUS_UA => sub { ### for the version number ### + require CPANPLUS::Internals; + "CPANPLUS/$CPANPLUS::Internals::VERSION" + }; +use constant TESTERS_URL => sub { + "http://testers.cpan.org/show/" . + $_[0] .".yaml" + }; +use constant TESTERS_DETAILS_URL + => sub { + 'http://testers.cpan.org/show/' . + $_[0] . '.html'; + }; + +use constant CREATE_FILE_URI + => sub { + my $dir = $_[0] or return; + return $dir =~ m|^/| + ? 'file:/' . $dir + : 'file://' . $dir; + }; + +use constant DOT_SHELL_DEFAULT_RC + => '.shell-default.rc'; + +use constant PREREQ_IGNORE => 0; +use constant PREREQ_INSTALL => 1; +use constant PREREQ_ASK => 2; +use constant PREREQ_BUILD => 3; +use constant BOOLEANS => [0,1]; +use constant CALLING_FUNCTION + => sub { my $lvl = $_[0] || 0; + return join '::', (caller(2+$lvl))[3] + }; +use constant PERL_CORE => 'perl'; + +use constant GET_XS_FILES => sub { my $dir = $_[0] or return; + require File::Find; + my @files; + File::Find::find( + sub { push @files, $File::Find::name + if $File::Find::name =~ /\.xs$/i + }, $dir ); + + return @files; + }; + +use constant INSTALL_LOG_FILE + => sub { my $obj = shift or return; + my $name = $obj->name; $name =~ s/::/-/g; + $name .= '-'. $obj->version; + $name .= '-'. scalar(time) . '.log'; + return $name; + }; + +use constant ON_WIN32 => $^O eq 'MSWin32'; +use constant ON_NETWARE => $^O eq 'NetWare'; +use constant ON_CYGWIN => $^O eq 'cygwin'; +use constant ON_VMS => $^O eq 'VMS'; + +use constant ON_OLD_CYGWIN => do { ON_CYGWIN and $] < 5.008 + ? loc( + "Your perl version for %1 is too low; ". + "Require %2 or higher for this function", + $^O, '5.8.0' ) + : ''; + }; + +### XXX these 2 are probably obsolete -- check & remove; +use constant DOT_EXISTS => '.exists'; + +use constant QUOTE_PERL_ONE_LINER + => sub { my $line = shift or return; + + ### use double quotes on these systems + return qq["$line"] + if ON_WIN32 || ON_NETWARE || ON_VMS; + + ### single quotes on the rest + return qq['$line']; + }; + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Constants/Report.pm b/lib/CPANPLUS/Internals/Constants/Report.pm new file mode 100644 index 0000000..10a14e6 --- /dev/null +++ b/lib/CPANPLUS/Internals/Constants/Report.pm @@ -0,0 +1,357 @@ +package CPANPLUS::Internals::Constants::Report; + +use strict; +use CPANPLUS::Error; + +use File::Spec; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +require Exporter; +use vars qw[$VERSION @ISA @EXPORT]; + +use Package::Constants; + + +$VERSION = 0.01; +@ISA = qw[Exporter]; +@EXPORT = Package::Constants->list( __PACKAGE__ ); + +### for the version +require CPANPLUS::Internals; + +### OS to regex map ### +my %OS = ( + Amiga => 'amigaos', + Atari => 'mint', + BSD => 'bsdos|darwin|freebsd|openbsd|netbsd', + Be => 'beos', + BeOS => 'beos', + Cygwin => 'cygwin', + Darwin => 'darwin', + EBCDIC => 'os390|os400|posix-bc|vmesa', + HPUX => 'hpux', + Linux => 'linux', + MSDOS => 'dos|os2|MSWin32|cygwin', + 'bin\\d*Mac'=> 'MacOS|darwin', # binMac, bin56Mac, bin58Mac... + Mac => 'MacOS|darwin', + MacPerl => 'MacOS', + MacOS => 'MacOS|darwin', + MacOSX => 'darwin', + MPE => 'mpeix', + MPEiX => 'mpeix', + OS2 => 'os2', + Plan9 => 'plan9', + RISCOS => 'riscos', + SGI => 'irix', + Solaris => 'solaris', + Unix => 'aix|bsdos|darwin|dgux|dynixptx|freebsd|'. + 'linux|hpux|machten|netbsd|next|openbsd|dec_osf|'. + 'svr4|sco_sv|unicos|unicosmk|solaris|sunos', + VMS => 'VMS', + VOS => 'VOS', + Win32 => 'MSWin32|cygwin', + Win32API => 'MSWin32|cygwin', +); + +use constant GRADE_FAIL => 'fail'; +use constant GRADE_PASS => 'pass'; +use constant GRADE_NA => 'na'; +use constant GRADE_UNKNOWN => 'unknown'; + +use constant MAX_REPORT_SEND + => 2; + +use constant CPAN_TESTERS_EMAIL + => 'cpan-testers@perl.org'; + +### the cpan mail account for this user ### +use constant CPAN_MAIL_ACCOUNT + => sub { + my $username = shift or return; + return $username . '@cpan.org'; + }; + +### check if this module is platform specific and if we're on that +### specific platform. Alternately, the module is not platform specific +### and we're always OK to send out test results. +use constant RELEVANT_TEST_RESULT + => sub { + my $mod = shift or return; + my $name = $mod->module; + my $specific; + for my $platform (keys %OS) { + if( $name =~ /\b$platform\b/i ) { + # beware the Mac != MAC + next if($platform eq 'Mac' && + $name !~ /\b$platform\b/); + $specific++; + return 1 if + $^O =~ /^(?:$OS{$platform})$/ + } + }; + return $specific ? 0 : 1; + }; + +use constant UNSUPPORTED_OS + => sub { + my $buffer = shift or return; + if( $buffer =~ + /No support for OS|OS unsupported/im ) { + return 1; + } + return 0; + }; + +use constant PERL_VERSION_TOO_LOW + => sub { + my $buffer = shift or return; + # ExtUtils::MakeMaker format + if( $buffer =~ + /Perl .*? required--this is only .*?/m ) { + return 1; + } + # Module::Build format + if( $buffer =~ + /ERROR:( perl:)? Version .*?( of perl)? is installed, but we need version >= .*?/m ) { + return 1; + } + return 0; + }; + +use constant NO_TESTS_DEFINED + => sub { + my $buffer = shift or return; + if( $buffer =~ + /(No tests defined( for [\w:]+ extension)?\.)/ + and $buffer !~ /\*\.t/m and + $buffer !~ /test\.pl/m + ) { + return $1 + } + + return; + }; + +### what stage did the test fail? ### +use constant TEST_FAIL_STAGE + => sub { + my $buffer = shift or return; + return $buffer =~ /(MAKE [A-Z]+).*/ + ? lc $1 : + 'fetch'; + }; + + +use constant MISSING_PREREQS_LIST + => sub { + my $buffer = shift; + my @list = map { s/.pm$//; s|/|::|g; $_ } + ($buffer =~ + m/\bCan\'t locate (\S+) in \@INC/g); + + ### make sure every missing prereq is only + ### listed ones + { my %seen; + @list = grep { !$seen{$_}++ } @list + } + + return @list; + }; + +use constant MISSING_EXTLIBS_LIST + => sub { + my $buffer = shift; + my @list = + ($buffer =~ + m/No library found for -l([-\w]+)/g); + + return @list; + }; + +use constant REPORT_MESSAGE_HEADER + => sub { + my ($version, $author) = @_; + return << "."; + +Dear $author, + +This is a computer-generated error report created automatically by +CPANPLUS, version $version. Testers personal comments may appear +at the end of this report. + +. + }; + +use constant REPORT_MESSAGE_FAIL_HEADER + => sub { + my($stage, $buffer) = @_; + return << "."; + +Thank you for uploading your work to CPAN. However, it appears that +there were some problems testing your distribution. + +TEST RESULTS: + +Below is the error stack from stage '$stage': + +$buffer + +. + }; + +use constant REPORT_MISSING_PREREQS + => sub { + my ($author,$email,@missing) = @_; + $author = ($author && $email) + ? "$author ($email)" + : 'Your Name Here'; + + my $modules = join "\n", @missing; + my $prereqs = join "\n", + map {"\t'$_'\t=> '0',". + " # or a minimum working version"} + @missing; + + return << "."; + +MISSING PREREQUISITES: + +It was observed that the test suite seem to fail without these modules: + +$modules + +As such, adding the prerequisite module(s) to 'PREREQ_PM' in your +Makefile.PL should solve this problem. For example: + +WriteMakefile( + AUTHOR => '$author', + ... # other information + PREREQ_PM => { +$prereqs + } +); + +If you are interested in making a more flexible Makefile.PL that can +probe for missing dependencies and install them, ExtUtils::AutoInstall +at may be +worth a look. + +Thanks! :-) + +. + }; + +use constant REPORT_MISSING_TESTS + => sub { + return << "."; +RECOMMENDATIONS: + +It would be very helpful if you could include even a simple test +script in the next release, so people can verify which platforms +can successfully install them, as well as avoid regression bugs? + +A simple 't/use.t' that says: + +#!/usr/bin/env perl -w +use strict; +use Test; +BEGIN { plan tests => 1 } + +use Your::Module::Here; ok(1); +exit; +__END__ + +would be appreciated. If you are interested in making a more robust +test suite, please see the Test::Simple, Test::More and Test::Tutorial +documentation at . + +Thanks! :-) + +. + }; + +use constant REPORT_LOADED_PREREQS + => sub { + my $mod = shift; + my $cb = $mod->parent; + my $prq = $mod->status->prereqs || {}; + + ### not every prereq may be coming from CPAN + ### so maybe we wont find it in our module + ### tree at all... + ### skip ones that cant be found in teh list + ### as reported in #12723 + my @prq = grep { defined } + map { $cb->module_tree($_) } + sort keys %$prq; + + ### no prereqs? + return '' unless @prq; + + ### some apparently, list what we loaded + my $str = << "."; +PREREQUISITES: + +Here is a list of prerequisites you specified and versions we +managed to load: + +. + $str .= join '', + map { my $want = $prq->{$_->name}; + + sprintf "\t%s %-30s %8s %8s\n", + do { $_->is_uptodate( + version => $want + ) ? ' ' : '!' + }, + $_->name, + $_->installed_version, + $want + + ### might be empty entries in there + } grep { defined $_ } @prq; + + return $str; + }; + +use constant REPORT_TESTS_SKIPPED + => sub { + return << "."; + +******************************** NOTE ******************************** +*** *** +*** The tests for this module were skipped during this build *** +*** *** +********************************************************************** + +. + }; + +use constant REPORT_MESSAGE_FOOTER + => sub { + return << "."; + +******************************** NOTE ******************************** +The comments above are created mechanically, possibly without manual +checking by the sender. As there are many people performing automatic +tests on each upload to CPAN, it is likely that you will receive +identical messages about the same problem. + +If you believe that the message is mistaken, please reply to the first +one with correction and/or additional informations, and do not take +it personally. We appreciate your patience. :) +********************************************************************** + +Additional comments: + +. + }; + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Extract.pm b/lib/CPANPLUS/Internals/Extract.pm new file mode 100644 index 0000000..544d589 --- /dev/null +++ b/lib/CPANPLUS/Internals/Extract.pm @@ -0,0 +1,236 @@ +package CPANPLUS::Internals::Extract; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Spec (); +use File::Basename (); +use Archive::Extract; +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Extract + +=head1 SYNOPSIS + + ### for source files ### + $self->_gunzip( file => 'foo.gz', output => 'blah.txt' ); + + ### for modules/packages ### + $dir = $self->_extract( module => $modobj, + extractdir => '/some/where' ); + +=head1 DESCRIPTION + +CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS. +It can do this by either a pure perl solution (preferred) with the +use of C and C, or with binaries, like +C and C. + +The flow looks like this: + + $cb->_extract + Delegate to Archive::Extract + +=head1 METHODS + +=head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] ) + +C<_extract> will take a module object and extract it to C +if provided, or the default location which is obtained from your +config. + +The file name is obtained by looking at C<< $modobj->status->fetch >> +and will be parsed to see if it's a tar or zip archive. + +If it's a zip archive, C<__unzip> will be called, otherwise C<__untar> +will be called. In the unlikely event the file is of neither format, +an error will be thrown. + +C<_extract> takes the following options: + +=over 4 + +=item module + +A C object. This is required. + +=item extractdir + +The directory to extract the archive to. By default this looks +something like: + /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME + +=item prefer_bin + +A flag indicating whether you prefer a pure perl solution, ie +C or C respectively, or a binary solution +like C and C. + +=item perl + +The path to the perl executable to use for any perl calls. Also used +to determine the build version directory for extraction. + +=item verbose + +Specifies whether to be verbose or not. Defaults to your corresponding +config entry. + +=item force + +Specifies whether to force the extraction or not. Defaults to your +corresponding config entry. + +=back + +All other options are passed on verbatim to C<__unzip> or C<__untar>. + +Returns the directory the file was extracted to on success and false +on failure. + +=cut + +sub _extract { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + + my( $mod, $verbose, $force ); + my $tmpl = { + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prefer_bin => { default => $conf->get_conf('prefer_bin') }, + extractdir => { default => $conf->get_conf('extractdir') }, + module => { required => 1, allow => IS_MODOBJ, store => \$mod }, + perl => { default => $^X }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### did we already extract it ? ### + my $loc = $mod->status->extract(); + + if( $loc && !$force ) { + msg(loc("Already extracted '%1' to '%2'. ". + "Won't extract again without force", + $mod->module, $loc), $verbose); + return $loc; + } + + ### did we already fetch the file? ### + my $file = $mod->status->fetch(); + unless( -s $file ) { + error( loc( "File '%1' has zero size: cannot extract", $file ) ); + return; + } + + ### the dir to extract to ### + my $to = $args->{'extractdir'} || + File::Spec->catdir( + $conf->get_conf('base'), + $self->_perl_version( perl => $args->{'perl'} ), + $conf->_get_build('moddir'), + ); + + ### delegate to Archive::Extract ### + ### set up some flags for archive::extract ### + local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'}; + local $Archive::Extract::DEBUG = $conf->get_conf('debug'); + local $Archive::Extract::WARN = $verbose; + + my $ae = Archive::Extract->new( archive => $file ); + + unless( $ae->extract( to => $to ) ) { + error( loc( "Unable to extract '%1' to '%2': %3", + $file, $to, $ae->error ) ); + return; + } + + ### if ->files is not filled, we dont know what the hell was + ### extracted.. try to offer a suggestion and bail :( + unless ( $ae->files ) { + error( loc( "'%1' was not able to determine extracted ". + "files from the archive. Instal '%2' and ensure ". + "it works properly and try again", + $ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) ); + return; + } + + + ### print out what files we extracted ### + msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files}; + + ### set them all to be +w for the owner, so we don't get permission + ### denied for overwriting files that are just +r + + ### this is to rigurous -- just change to +w for the owner [cpan #13358] + #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) } + # @{$ae->files}; + + for my $file ( @{$ae->files} ) { + my $path = File::Spec->rel2abs( File::Spec->catdir($to, $file) ); + + $self->_mode_plus_w( file => $path ); + } + + ### check the return value for the extracted path ### + ### Make an educated guess if we didn't get an extract_path + ### back + ### XXX apparently some people make their own dists and they + ### pack up '.' which means the leading directory is '.' + ### and only the second directory is the actual module directory + ### so, we'll have to check if our educated guess exists first, + ### then see if the extract path works.. and if nothing works... + ### well, then we really don't know. + + my $dir; + for my $try ( File::Spec->rel2abs( File::Spec->catdir( + $to, $mod->package_name .'-'. $mod->package_version ) ), + File::Spec->rel2abs( $ae->extract_path ), + ) { + ($dir = $try) && last if -d $try; + } + + ### test if the dir exists ### + unless( $dir && -d $dir ) { + error(loc("Unable to determine extract dir for '%1'",$mod->module)); + return; + + } else { + msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose); + + ### register where we extracted the files to, + ### also store what files were extracted + $mod->status->extract( $dir ); + $mod->status->files( $ae->files ); + } + + ### also, figure out what kind of install we're dealing with ### + $mod->get_installer_type(); + + return $mod->status->extract(); +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Fetch.pm b/lib/CPANPLUS/Internals/Fetch.pm new file mode 100644 index 0000000..b8ad371 --- /dev/null +++ b/lib/CPANPLUS/Internals/Fetch.pm @@ -0,0 +1,372 @@ +package CPANPLUS::Internals::Fetch; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use File::Fetch; +use File::Spec; +use Cwd qw[cwd]; +use IPC::Cmd qw[run]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Fetch + +=head1 SYNOPSIS + + my $output = $cb->_fetch( + module => $modobj, + fetchdir => '/path/to/save/to', + verbose => BOOL, + force => BOOL, + ); + + $cb->_add_fail_host( host => 'foo.com' ); + $cb->_host_ok( host => 'foo.com' ); + + +=head1 DESCRIPTION + +CPANPLUS::Internals::Fetch fetches files from either ftp, http, file +or rsync mirrors. + +This is the rough flow: + + $cb->_fetch + Delegate to File::Fetch; + + +=head1 METHODS + +=cut + +=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL] ) + +C<_fetch> will fetch files based on the information in a module +object. You always need a module object. If you want a fake module +object for a one-off fetch, look at C. + +C is the place to save the file to. Usually this +information comes from your configuration, but you can override it +expressly if needed. + +C lets you specify an URI to get this file from. If you +do not specify one, your list of configured hosts will be probed to +download the file from. + +C forces a new download, even if the file already exists. + +C simply indicates whether or not to print extra messages. + +C indicates whether you prefer the use of commandline +programs over perl modules. Defaults to your corresponding config +setting. + +C<_fetch> figures out, based on the host list, what scheme to use and +from there, delegates to C do the actual fetching. + +Returns the path of the output file on success, false on failure. + +Note that you can set a C on certain methods in the config. +Simply add the identifying name of the method (ie, C) to: + $conf->_set_fetch( blacklist => ['lwp'] ); + +And the C function will be skipped by C. + +=cut + +sub _fetch { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + local $Params::Check::NO_DUPLICATES = 0; + + my ($modobj, $verbose, $force, $fetch_from); + my $tmpl = { + module => { required => 1, allow => IS_MODOBJ, store => \$modobj }, + fetchdir => { default => $conf->get_conf('fetchdir') }, + fetch_from => { default => '', store => \$fetch_from }, + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + prefer_bin => { default => $conf->get_conf('prefer_bin') }, + }; + + + my $args = check( $tmpl, \%hash ) or return; + + ### check if we already downloaded the thing ### + if( (my $where = $modobj->status->fetch()) && !$force ) { + msg(loc("Already fetched '%1' to '%2', " . + "won't fetch again without force", + $modobj->module, $where ), $verbose ); + return $where; + } + + my ($remote_file, $local_file, $local_path); + + ### build the local path to downlaod to ### + { + $local_path = $args->{fetchdir} || + File::Spec->catdir( + $conf->get_conf('base'), + $modobj->path, + ); + + ### create the path if it doesn't exist ### + unless( -d $local_path ) { + unless( $self->_mkdir( dir => $local_path ) ) { + msg( loc("Could not create path '%1'", $local_path), $verbose); + return; + } + } + + $local_file = File::Spec->rel2abs( + File::Spec->catfile( + $local_path, + $modobj->package, + ) + ); + } + + ### do we already have the file? ### + if( -e $local_file ) { + + if( $args->{force} ) { + + ### some fetches will fail if the files exist already, so let's + ### delete them first + unlink $local_file + or msg( loc("Could not delete %1, some methods may " . + "fail to force a download", $local_file), $verbose); + } else { + + ### store where we fetched it ### + $modobj->status->fetch( $local_file ); + + return $local_file; + } + } + + + ### we got a custom URI + if ( $fetch_from ) { + my $abs = $self->__file_fetch( from => $fetch_from, + to => $local_path, + verbose => $verbose ); + + unless( $abs ) { + error(loc("Unable to download '%1'", $fetch_from)); + return; + } + + ### store where we fetched it ### + $modobj->status->fetch( $abs ); + + return $abs; + + ### we will get it from one of our mirrors + } else { + ### build the remote path to download from ### + { $remote_file = File::Spec::Unix->catfile( + $modobj->path, + $modobj->package, + ); + unless( $remote_file ) { + error( loc('No remote file given for download') ); + return; + } + } + + ### see if we even have a host or a method to use to download with ### + my $found_host; + my @maybe_bad_host; + + HOST: { + ### F*CKING PIECE OF F*CKING p4 SHIT makes + ### '$File :: Fetch::SOME_VAR' + ### into a meta variable and starts substituting the file name... + ### GRAAAAAAAAAAAAAAAAAAAAAAH! + ### use ' to combat it! + + ### set up some flags for File::Fetch ### + local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist'); + local $File'Fetch::TIMEOUT = $conf->get_conf('timeout'); + local $File'Fetch::DEBUG = $conf->get_conf('debug'); + local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive'); + local $File'Fetch::FROM_EMAIL = $conf->get_conf('email'); + local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin'); + local $File'Fetch::WARN = $verbose; + + + ### loop over all hosts we have ### + for my $host ( @{$conf->get_conf('hosts')} ) { + $found_host++; + + my $mirror_path = File::Spec::Unix->catfile( + $host->{'path'}, $remote_file + ); + + ### build pretty print uri ### + my $where; + if( $host->{'scheme'} eq 'file' ) { + $where = CREATE_FILE_URI->( + File::Spec::Unix->rel2abs( + File::Spec::Unix->catdir( + grep { defined $_ && length $_ } + $host->{'host'}, + $mirror_path + ) + ) + ); + } else { + my %args = ( scheme => $host->{scheme}, + host => $host->{host}, + path => $mirror_path, + ); + + $where = $self->_host_to_uri( %args ); + } + + my $abs = $self->__file_fetch( from => $where, + to => $local_path, + verbose => $verbose ); + + ### we got a path back? + if( $abs ) { + ### store where we fetched it ### + $modobj->status->fetch( $abs ); + + ### this host is good, the previous ones are apparently + ### not, so mark them as such. + $self->_add_fail_host( host => $_ ) for @maybe_bad_host; + + return $abs; + } + + ### so we tried to get the file but didn't actually fetch it -- + ### there's a chance this host is bad. mark it as such and + ### actually flag it back if we manage to get the file + ### somewhere else + push @maybe_bad_host, $host; + } + } + + $found_host + ? error(loc("Fetch failed: host list exhausted " . + "-- are you connected today?")) + : error(loc("No hosts found to download from " . + "-- check your config")); + } + + return; +} + +sub __file_fetch { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my ($where, $local_path, $verbose); + my $tmpl = { + from => { required => 1, store => \$where }, + to => { required => 1, store => \$local_path }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return; + + msg(loc("Trying to get '%1'", $where ), $verbose ); + + ### build the object ### + my $ff = File::Fetch->new( uri => $where ); + + ### sanity check ### + error(loc("Bad uri '%1'",$where)), return unless $ff; + + if( my $file = $ff->fetch( to => $local_path ) ) { + unless( -e $file && -s _ ) { + msg(loc("'%1' said it fetched '%2', but it was not created", + 'File::Fetch', $file), $verbose); + + } else { + my $abs = File::Spec->rel2abs( $file ); + return $abs; + } + + } else { + error(loc("Fetching of '%1' failed: %2", $where, $ff->error)); + } + + return; +} + +=pod + +=head2 _add_fail_host( host => $host_hashref ) + +Mark a particular host as bad. This makes C +skip it in fetches until this cache is flushed. + +=head2 _host_ok( host => $host_hashref ) + +Query the cache to see if this host is ok, or if it has been flagged +as bad. + +Returns true if the host is ok, false otherwise. + +=cut + +{ ### caching functions ### + + sub _add_fail_host { + my $self = shift; + my %hash = @_; + + my $host; + my $tmpl = { + host => { required => 1, default => {}, + strict_type => 1, store => \$host }, + }; + + check( $tmpl, \%hash ) or return; + + return $self->_hosts->{$host} = 1; + } + + sub _host_ok { + my $self = shift; + my %hash = @_; + + my $host; + my $tmpl = { + host => { required => 1, store => \$host }, + }; + + check( $tmpl, \%hash ) or return; + + return $self->_hosts->{$host} ? 0 : 1; + } +} + + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Report.pm b/lib/CPANPLUS/Internals/Report.pm new file mode 100644 index 0000000..ffcb4f0 --- /dev/null +++ b/lib/CPANPLUS/Internals/Report.pm @@ -0,0 +1,609 @@ +package CPANPLUS::Internals::Report; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Constants::Report; + +use Data::Dumper; + +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Module::Load::Conditional qw[can_load]; + +$Params::Check::VERBOSE = 1; + +### for the version ### +require CPANPLUS::Internals; + +=head1 NAME + +CPANPLUS::Internals::Report + +=head1 SYNOPSIS + + ### enable test reporting + $cb->configure_object->set_conf( cpantest => 1 ); + + ### set custom mx host, shouldn't normally be needed + $cb->configure_object->set_conf( cpantest_mx => 'smtp.example.com' ); + +=head1 DESCRIPTION + +This module provides all the functionality to send test reports to +C using the C module. + +All methods will be called automatically if you have C +configured to enable test reporting (see the C). + +=head1 METHODS + +=head2 $bool = $cb->_have_query_report_modules + +This function checks if all the required modules are here for querying +reports. It returns true and loads them if they are, or returns false +otherwise. + +=head2 $bool = $cb->_have_send_report_modules + +This function checks if all the required modules are here for sending +reports. It returns true and loads them if they are, or returns false +otherwise. + +=cut +{ my $query_list = { + LWP => '0.0', + 'LWP::UserAgent' => '0.0', + 'HTTP::Request' => '0.0', + URI => '0.0', + YAML => '0.0', + }; + + my $send_list = { + %$query_list, + 'Test::Reporter' => 1.27, + }; + + sub _have_query_report_modules { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $tmpl = { + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + return can_load( modules => $query_list, verbose => $args->{verbose} ) + ? 1 + : 0; + } + + sub _have_send_report_modules { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $tmpl = { + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + return can_load( modules => $send_list, verbose => $args->{verbose} ) + ? 1 + : 0; + } +} + +=head2 @list = $cb->_query_report( module => $modobj, [all_versions => BOOL, verbose => BOOL] ) + +This function queries the CPAN testers database at +I for test results of specified module objects, +module names or distributions. + +The optional argument C controls whether all versions of +a given distribution should be grabbed. It defaults to false +(fetching only reports for the current version). + +Returns the a list with the following data structures (for CPANPLUS +version 0.042) on success, or false on failure: + + { + 'grade' => 'PASS', + 'dist' => 'CPANPLUS-0.042', + 'platform' => 'i686-pld-linux-thread-multi' + }, + { + 'grade' => 'PASS', + 'dist' => 'CPANPLUS-0.042', + 'platform' => 'i686-linux-thread-multi' + }, + { + 'grade' => 'FAIL', + 'dist' => 'CPANPLUS-0.042', + 'platform' => 'cygwin-multi-64int', + 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371' + }, + { + 'grade' => 'FAIL', + 'dist' => 'CPANPLUS-0.042', + 'platform' => 'i586-linux', + 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396' + }, + +The status of the test can be one of the following: +UNKNOWN, PASS, FAIL or NA (not applicable). + +=cut + +sub _query_report { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($mod, $verbose, $all); + my $tmpl = { + module => { required => 1, allow => IS_MODOBJ, + store => \$mod }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + all_versions => { default => 0, store => \$all }, + }; + + check( $tmpl, \%hash ) or return; + + ### check if we have the modules we need for querying + return unless $self->_have_query_report_modules( verbose => 1 ); + + ### new user agent ### + my $ua = LWP::UserAgent->new; + $ua->agent( CPANPLUS_UA->() ); + + ### set proxies if we have them ### + $ua->env_proxy(); + + my $url = TESTERS_URL->($mod->package_name); + my $req = HTTP::Request->new( GET => $url); + + msg( loc("Fetching: '%1'", $url), $verbose ); + + my $res = $ua->request( $req ); + + unless( $res->is_success ) { + error( loc( "Fetching report for '%1' failed: %2", + $url, $res->message ) ); + return; + } + + my $aref = YAML::Load( $res->content ); + + my $dist = $mod->package_name .'-'. $mod->package_version; + + my @rv; + for my $href ( @$aref ) { + next unless $all or defined $href->{'distversion'} && + $href->{'distversion'} eq $dist; + + push @rv, { platform => $href->{'platform'}, + grade => $href->{'action'}, + dist => $href->{'distversion'}, + ( $href->{'action'} eq 'FAIL' + ? (details => TESTERS_DETAILS_URL->($mod->package_name)) + : () + ) }; + } + + return @rv if @rv; + return; +} + +=pod + +=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, dontcc => BOOL, verbose => BOOL, force => BOOL]); + +This function sends a testers report to C for a +particular distribution. +It returns true on success, and false on failure. + +It takes the following options: + +=over 4 + +=item module + +The module object of this particular distribution + +=item buffer + +The output buffer from the 'make/make test' process + +=item failed + +Boolean indicating if the 'make/make test' went wrong + +=item save + +Boolean indicating if the report should be saved locally instead of +mailed out. If provided, this function will return the location the +report was saved to, rather than a simple boolean 'TRUE'. + +Defaults to false. + +=item address + +The email address to mail the report for. You should never need to +override this, but it might be useful for debugging purposes. + +Defaults to C. + +=item dontcc + +Boolean indicating whether or not we should Cc: the author. If false, +previous error reports are inspected and checked if the author should +be mailed. If set to true, these tests are skipped and the author is +definitely not Cc:'d. +You should probably not change this setting. + +Defaults to false. + +=item verbose + +Boolean indicating on whether or not to be verbose. + +Defaults to your configuration settings + +=item force + +Boolean indicating whether to force the sending, even if the max +amount of reports for fails have already been reached, or if you +may already have sent it before. + +Defaults to your configuration settings + +=back + +=cut + +sub _send_report { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + ### do you even /have/ test::reporter? ### + unless( $self->_have_send_report_modules(verbose => 1) ) { + error( loc( "You don't have '%1' (or modules required by '%2') ". + "installed, you cannot report test results.", + 'Test::Reporter', 'Test::Reporter' ) ); + return; + } + + ### check arguments ### + my ($buffer, $failed, $mod, $verbose, $force, $address, $save, $dontcc, + $tests_skipped ); + my $tmpl = { + module => { required => 1, store => \$mod, allow => IS_MODOBJ }, + buffer => { required => 1, store => \$buffer }, + failed => { required => 1, store => \$failed }, + address => { default => CPAN_TESTERS_EMAIL, store => \$address }, + save => { default => 0, store => \$save }, + dontcc => { default => 0, store => \$dontcc }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + force => { default => $conf->get_conf('force'), + store => \$force }, + tests_skipped + => { default => 0, store => \$tests_skipped }, + }; + + check( $tmpl, \%hash ) or return; + + ### get the data to fill the email with ### + my $name = $mod->module; + my $dist = $mod->package_name . '-' . $mod->package_version; + my $author = $mod->author->author; + my $email = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author ); + my $cp_conf = $conf->get_conf('cpantest') || ''; + my $int_ver = $CPANPLUS::Internals::VERSION; + my $cb = $mod->parent; + + + ### determine the grade now ### + + my $grade; + ### check if this is a platform specific module ### + ### if we failed the test, there may be reasons why + ### an 'NA' might have to be insted + GRADE: { if ( $failed ) { + + + ### XXX duplicated logic between this block + ### and REPORTED_LOADED_PREREQS :( + + ### figure out if the prereqs are on CPAN at all + ### -- if not, send NA grade + ### Also, if our version of prereqs is too low, + ### -- send NA grade. + ### This is to address bug: #25327: do not count + ### as FAIL modules where prereqs are not filled + { my $prq = $mod->status->prereqs || {}; + + while( my($prq_name,$prq_ver) = each %$prq ) { + my $obj = $cb->module_tree( $prq_name ); + + unless( $obj ) { + msg(loc( "Prerequisite '%1' for '%2' could not be obtained". + " from CPAN -- sending N/A grade", + $prq_name, $name ), $verbose ); + + $grade = GRADE_NA; + last GRADE; + } + + if( $cb->_vcmp( $prq_ver, $obj->installed_version ) > 0 ) { + msg(loc( "Installed version of '%1' ('%2') is too low for ". + "'%3' (needs '%4') -- sending N/A grade", + $prq_name, $obj->installed_version, + $name, $prq_ver ), $verbose ); + + $grade = GRADE_NA; + last GRADE; + } + } + } + + unless( RELEVANT_TEST_RESULT->($mod) ) { + msg(loc( + "'%1' is a platform specific module, and the test results on". + " your platform are not relevant --sending N/A grade.", + $name), $verbose); + + $grade = GRADE_NA; + + } elsif ( UNSUPPORTED_OS->( $buffer ) ) { + msg(loc( + "'%1' is a platform specific module, and the test results on". + " your platform are not relevant --sending N/A grade.", + $name), $verbose); + + $grade = GRADE_NA; + + ### you dont have a high enough perl version? + } elsif ( PERL_VERSION_TOO_LOW->( $buffer ) ) { + msg(loc("'%1' requires a higher version of perl than your current ". + "version -- sending N/A grade.", $name), $verbose); + + $grade = GRADE_NA; + + ### perhaps where were no tests... + ### see if the thing even had tests ### + } elsif ( NO_TESTS_DEFINED->( $buffer ) ) { + $grade = GRADE_UNKNOWN; + + } else { + + $grade = GRADE_FAIL; + } + + ### if we got here, it didn't fail and tests were present.. so a PASS + ### is in order + } else { + $grade = GRADE_PASS; + } } + + ### so an error occurred, let's see what stage it went wrong in ### + my $message; + if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) { + + ### return if one or more missing external libraries + if( my @missing = MISSING_EXTLIBS_LIST->($buffer) ) { + msg(loc("Not sending test report - " . + "external libraries not pre-installed")); + return 1; + } + + ### will be 'fetch', 'make', 'test', 'install', etc ### + my $stage = TEST_FAIL_STAGE->($buffer); + + ### return if we're only supposed to report make_test failures ### + return 1 if $cp_conf =~ /\bmaketest_only\b/i + and ($stage !~ /\btest\b/); + + ### the header + $message = REPORT_MESSAGE_HEADER->( $int_ver, $author ); + + ### the bit where we inform what went wrong + $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer ); + + ### was it missing prereqs? ### + if( my @missing = MISSING_PREREQS_LIST->($buffer) ) { + if(!$self->_verify_missing_prereqs( + module => $mod, + missing => \@missing + )) { + msg(loc("Not sending test report - " . + "bogus missing prerequisites report")); + return 1; + } + $message .= REPORT_MISSING_PREREQS->($author,$email,@missing); + } + + ### was it missing test files? ### + if( NO_TESTS_DEFINED->($buffer) ) { + $message .= REPORT_MISSING_TESTS->(); + } + + ### add a list of what modules have been loaded of your prereqs list + $message .= REPORT_LOADED_PREREQS->($mod); + + ### the footer + $message .= REPORT_MESSAGE_FOOTER->(); + + ### it may be another grade than fail/unknown.. may be worth noting + ### that tests got skipped, since the buffer is not added in + } elsif ( $tests_skipped ) { + $message .= REPORT_TESTS_SKIPPED->(); + } + + ### if it failed, and that already got reported, we're not cc'ing the + ### author. Also, 'dont_cc' might be in the config, so check this; + my $dont_cc_author = $dontcc; + + unless( $dont_cc_author ) { + if( $cp_conf =~ /\bdont_cc\b/i ) { + $dont_cc_author++; + + } elsif ( $grade eq GRADE_PASS ) { + $dont_cc_author++ + + } elsif( $grade eq GRADE_FAIL ) { + my @already_sent = + $self->_query_report( module => $mod, verbose => $verbose ); + + ### if we can't fetch it, we'll just assume no one + ### mailed him yet + my $count = 0; + if( @already_sent ) { + for my $href (@already_sent) { + $count++ if uc $href->{'grade'} eq uc GRADE_FAIL; + } + } + + if( $count > MAX_REPORT_SEND and !$force) { + msg(loc("'%1' already reported for '%2', ". + "not cc-ing the author", + GRADE_FAIL, $dist ), $verbose ); + $dont_cc_author++; + } + } + } + + ### reporter object ### + my $reporter = Test::Reporter->new( + grade => $grade, + distribution => $dist, + via => "CPANPLUS $int_ver", + debug => $conf->get_conf('debug'), + ); + + ### set a custom mx, if requested + $reporter->mx( [ $conf->get_conf('cpantest_mx') ] ) + if $conf->get_conf('cpantest_mx'); + + ### set the from address ### + $reporter->from( $conf->get_conf('email') ) + if $conf->get_conf('email') !~ /\@example\.\w+$/i; + + ### give the user a chance to programattically alter the message + $message = $self->_callbacks->munge_test_report->($mod, $message, $grade); + + ### add the body if we have any ### + $reporter->comments( $message ) if defined $message && length $message; + + ### do a callback to ask if we should send the report + unless ($self->_callbacks->send_test_report->($mod, $grade)) { + msg(loc("Ok, not sending test report")); + return 1; + } + + ### do a callback to ask if we should edit the report + if ($self->_callbacks->edit_test_report->($mod, $grade)) { + ### test::reporter 1.20 and lower don't have a way to set + ### the preferred editor with a method call, but it does + ### respect your env variable, so let's set that. + local $ENV{VISUAL} = $conf->get_program('editor') + if $conf->get_program('editor'); + + $reporter->edit_comments; + } + + ### people to mail ### + my @inform; + #push @inform, $email unless $dont_cc_author; + + ### allow to be overridden, but default to the normal address ### + $reporter->address( $address ); + + ### should we save it locally? ### + if( $save ) { + if( my $file = $reporter->write() ) { + msg(loc("Successfully wrote report for '%1' to '%2'", + $dist, $file), $verbose); + return $file; + + } else { + error(loc("Failed to write report for '%1'", $dist)); + return; + } + + ### should we send it to a bunch of people? ### + ### XXX should we do an 'already sent' check? ### + } elsif( $reporter->send( @inform ) ) { + msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist), + $verbose); + return 1; + + ### something broke :( ### + } else { + error(loc("Could not send '%1' report for '%2': %3", + $grade, $dist, $reporter->errstr)); + return; + } +} + +sub _verify_missing_prereqs { + my $self = shift; + my %hash = @_; + + ### check arguments ### + my ($mod, $missing); + my $tmpl = { + module => { required => 1, store => \$mod }, + missing => { required => 1, store => \$missing }, + }; + + check( $tmpl, \%hash ) or return; + + + my %missing = map {$_ => 1} @$missing; + my $conf = $self->configure_object; + my $extract = $mod->status->extract; + + ### Read pre-requisites from Makefile.PL or Build.PL (if there is one), + ### of the form: + ### 'PREREQ_PM' => { + ### 'Compress::Zlib' => '1.20', + ### 'Test::More' => 0, + ### }, + ### Build.PL uses 'requires' instead of 'PREREQ_PM'. + + my @search; + push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->()); + push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->()); + + for my $file ( @search ) { + if(-e $file and -r $file) { + my $slurp = $self->_get_file_contents(file => $file); + my ($prereq) = + ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s); + my @prereq = + ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg); + delete $missing{$_} for(@prereq); + } + } + + return 1 if(keys %missing); # There ARE missing prerequisites + return; # All prerequisites accounted for +} + +1; + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Search.pm b/lib/CPANPLUS/Internals/Search.pm new file mode 100644 index 0000000..30443f0 --- /dev/null +++ b/lib/CPANPLUS/Internals/Search.pm @@ -0,0 +1,316 @@ +package CPANPLUS::Internals::Search; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Module; +use CPANPLUS::Module::Author; + +use File::Find; +use File::Spec; + +use Params::Check qw[check allow]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Search + +=head1 SYNOPSIS + + my $aref = $cpan->_search_module_tree( + type => 'package', + allow => [qr/DBI/], + ); + + my $aref = $cpan->_search_author_tree( + type => 'cpanid', + data => \@old_results, + verbose => 1, + allow => [qw|KANE AUTRIJUS|], + ); + + my $aref = $cpan->_all_installed( ); + +=head1 DESCRIPTION + +The functions in this module are designed to find module(objects) +based on certain criteria and return them. + +=head1 METHODS + +=head2 _search_module_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] ) + +Searches the moduletree for module objects matching the criteria you +specify. Returns an array ref of module objects on success, and false +on failure. + +It takes the following arguments: + +=over 4 + +=item type + +This can be any of the accessors for the C objects. +This is a required argument. + +=item allow + +A set of rules, or more precisely, a list of regexes (via C or +plain strings), that the C must adhere too. You can specify as +many as you like, and it will be treated as an C search. +For an C search, see the C argument. + +This is a required argument. + +=item data + +An arrayref of previous search results. This is the way to do an C +search -- C<_search_module_tree> will only search the module objects +specified in C if provided, rather than the moduletree itself. + +=back + +=cut + +# Although the Params::Check solution is more graceful, it is WAY too slow. +# +# This sample script: +# +# use CPANPLUS::Backend; +# my $cb = new CPANPLUS::Backend; +# $cb->module_tree; +# my @list = $cb->search( type => 'module', allow => [qr/^Acme/] ); +# print $_->module, $/ for @list; +# +# Produced the following output using Dprof WITH params::check code +# +# Total Elapsed Time = 3.670024 Seconds +# User+System Time = 3.390373 Seconds +# Exclusive Times +# %Time ExclSec CumulS #Calls sec/call Csec/c Name +# 88.7 3.008 4.463 20610 0.0001 0.0002 Params::Check::check +# 47.4 1.610 1.610 1 1.6100 1.6100 Storable::net_pstore +# 25.6 0.869 0.737 20491 0.0000 0.0000 Locale::Maketext::Simple::_default +# _gettext +# 23.2 0.789 0.524 40976 0.0000 0.0000 Params::Check::_who_was_it +# 23.2 0.789 0.677 20610 0.0000 0.0000 Params::Check::_sanity_check +# 19.7 0.670 0.670 1 0.6700 0.6700 Storable::pretrieve +# 14.1 0.480 0.211 41350 0.0000 0.0000 Params::Check::_convert_case +# 11.5 0.390 0.256 20610 0.0000 0.0000 Params::Check::_hashdefs +# 11.5 0.390 0.255 20697 0.0000 0.0000 Params::Check::_listreqs +# 11.4 0.389 0.177 20653 0.0000 0.0000 Params::Check::_canon_key +# 10.9 0.370 0.356 20697 0.0000 0.0000 Params::Check::_hasreq +# 8.02 0.272 4.750 1 0.2723 4.7501 CPANPLUS::Internals::Search::_sear +# ch_module_tree +# 6.49 0.220 0.086 20653 0.0000 0.0000 Params::Check::_iskey +# 6.19 0.210 0.077 20488 0.0000 0.0000 Params::Check::_store_error +# 5.01 0.170 0.036 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__ +# +# and this output /without/ +# +# Total Elapsed Time = 2.803426 Seconds +# User+System Time = 2.493426 Seconds +# Exclusive Times +# %Time ExclSec CumulS #Calls sec/call Csec/c Name +# 56.9 1.420 1.420 1 1.4200 1.4200 Storable::net_pstore +# 25.6 0.640 0.640 1 0.6400 0.6400 Storable::pretrieve +# 9.22 0.230 0.096 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__ +# 7.06 0.176 0.272 1 0.1762 0.2719 CPANPLUS::Internals::Search::_sear +# ch_module_tree +# 3.21 0.080 0.098 10 0.0080 0.0098 IPC::Cmd::BEGIN +# 1.60 0.040 0.205 13 0.0031 0.0158 CPANPLUS::Internals::BEGIN +# 1.20 0.030 0.030 29 0.0010 0.0010 vars::BEGIN +# 1.20 0.030 0.117 10 0.0030 0.0117 Log::Message::BEGIN +# 1.20 0.030 0.029 9 0.0033 0.0033 CPANPLUS::Internals::Search::BEGIN +# 0.80 0.020 0.020 5 0.0040 0.0040 DynaLoader::dl_load_file +# 0.80 0.020 0.127 10 0.0020 0.0127 CPANPLUS::Module::BEGIN +# 0.80 0.020 0.389 2 0.0099 0.1944 main::BEGIN +# 0.80 0.020 0.359 12 0.0017 0.0299 CPANPLUS::Backend::BEGIN +# 0.40 0.010 0.010 30 0.0003 0.0003 Config::FETCH +# 0.40 0.010 0.010 18 0.0006 0.0005 Locale::Maketext::Simple::load_loc +# + +sub _search_module_tree { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($mods,$list,$verbose,$type); + my $tmpl = { + data => { default => [values %{$self->module_tree}], + strict_type=> 1, store => \$mods }, + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + type => { required => 1, allow => [CPANPLUS::Module->accessors()], + store => \$type }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + { local $Params::Check::VERBOSE = 0; + + my @rv; + for my $mod (@$mods) { + #push @rv, $mod if check( + # { $type => { allow => $list } }, + # { $type => $mod->$type() } + # ); + push @rv, $mod if allow( $mod->$type() => $list ); + + } + return \@rv; + } +} + +=pod + +=head2 _search_author_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] ) + +Searches the authortree for author objects matching the criteria you +specify. Returns an array ref of author objects on success, and false +on failure. + +It takes the following arguments: + +=over 4 + +=item type + +This can be any of the accessors for the C +objects. This is a required argument. + +=item allow + + +A set of rules, or more precisely, a list of regexes (via C or +plain strings), that the C must adhere too. You can specify as +many as you like, and it will be treated as an C search. +For an C search, see the C argument. + +This is a required argument. + +=item data + +An arrayref of previous search results. This is the way to do an C +search -- C<_search_author_tree> will only search the author objects +specified in C if provided, rather than the authortree itself. + +=back + +=cut + +sub _search_author_tree { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($authors,$list,$verbose,$type); + my $tmpl = { + data => { default => [values %{$self->author_tree}], + strict_type=> 1, store => \$authors }, + allow => { required => 1, default => [ ], strict_type => 1, + store => \$list }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + type => { required => 1, allow => [CPANPLUS::Module::Author->accessors()], + store => \$type }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + { local $Params::Check::VERBOSE = 0; + + my @rv; + for my $auth (@$authors) { + #push @rv, $auth if check( + # { $type => { allow => $list } }, + # { $type => $auth->$type } + # ); + push @rv, $auth if allow( $auth->$type() => $list ); + } + return \@rv; + } + + +} + +=pod + +=head2 _all_installed() + +This function returns an array ref of module objects of modules that +are installed on this system. + +=cut + +sub _all_installed { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my %seen; my @rv; + + + ### File::Find uses lstat, which quietly becomes stat on win32 + ### it then uses -l _ which is not allowed by the statbuffer because + ### you did a stat, not an lstat (duh!). so don't tell win32 to + ### follow symlinks, as that will break badly + my %find_args = (); + $find_args{'follow_fast'} = 1 unless $^O eq 'MSWin32'; + + ### never use the @INC hooks to find installed versions of + ### modules -- they're just there in case they're not on the + ### perl install, but the user shouldn't trust them for *other* + ### modules! + ### XXX CPANPLUS::inc is now obsolete, remove the calls + #local @INC = CPANPLUS::inc->original_inc; + + for my $dir (@INC ) { + next if $dir eq '.'; + + ### not a directory after all ### + next unless -d $dir; + + ### make sure to clean up the directories just in case, + ### as we're making assumptions about the length + ### This solves rt.cpan issue #19738 + $dir = File::Spec->canonpath( $dir ); + + File::Find::find( + { %find_args, + wanted => sub { + + return unless /\.pm$/i; + my $mod = $File::Find::name; + + $mod = substr($mod, length($dir) + 1, -3); + $mod = join '::', File::Spec->splitdir($mod); + + return if $seen{$mod}++; + my $modobj = $self->module_tree($mod) or return; + + push @rv, $modobj; + }, + }, $dir + ); + } + + return \@rv; +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Source.pm b/lib/CPANPLUS/Internals/Source.pm new file mode 100644 index 0000000..c58632b --- /dev/null +++ b/lib/CPANPLUS/Internals/Source.pm @@ -0,0 +1,1011 @@ +package CPANPLUS::Internals::Source; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author; +use CPANPLUS::Internals::Constants; + +use Archive::Extract; + +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Params::Check qw[check]; +use IPC::Cmd qw[can_run]; +use Module::Load::Conditional qw[can_load]; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Source + +=head1 SYNOPSIS + + ### lazy load author/module trees ### + + $cb->_author_tree; + $cb->_module_tree; + +=head1 DESCRIPTION + +CPANPLUS::Internals::Source controls the updating of source files and +the parsing of them into usable module/author trees to be used by +C. + +Functions exist to check if source files are still C as +well as update them, and then parse them. + +The flow looks like this: + + $cb->_author_tree || $cb->_module_tree + $cb->__check_trees + $cb->__check_uptodate + $cb->_update_source + $cb->_build_trees + $cb->__create_author_tree + $cb->__retrieve_source + $cb->__create_module_tree + $cb->__retrieve_source + $cb->__create_dslip_tree + $cb->__retrieve_source + $cb->_save_source + + $cb->_dslip_defs + +=head1 METHODS + +=cut + +{ + my $recurse; # flag to prevent recursive calls to *_tree functions + + ### lazy loading of module tree + sub _module_tree { + my $self = $_[0]; + + unless ($self->{_modtree} or $recurse++ > 0) { + my $uptodate = $self->_check_trees( @_[1..$#_] ); + $self->_build_trees(uptodate => $uptodate); + } + + $recurse--; + return $self->{_modtree}; + } + + ### lazy loading of author tree + sub _author_tree { + my $self = $_[0]; + + unless ($self->{_authortree} or $recurse++ > 0) { + my $uptodate = $self->_check_trees( @_[1..$#_] ); + $self->_build_trees(uptodate => $uptodate); + } + + $recurse--; + return $self->{_authortree}; + } + +} + +=pod + +=head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] ) + +Retrieve source files and return a boolean indicating whether or not +the source files are up to date. + +Takes several arguments: + +=over 4 + +=item update_source + +A flag to force re-fetching of the source files, even +if they are still up to date. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +=cut + +### retrieve source files, and returns a boolean indicating if it's up to date +sub _check_trees { + my ($self, %hash) = @_; + my $conf = $self->configure_object; + + my $update_source; + my $verbose; + my $path; + + my $tmpl = { + path => { default => $conf->get_conf('base'), + store => \$path + }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose + }, + update_source => { default => 0, store => \$update_source }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### if the user never wants to update their source without explicitly + ### telling us, shortcircuit here + return 1 if $conf->get_conf('no_update') && !$update_source; + + ### a check to see if our source files are still up to date ### + msg( loc("Checking if source files are up to date"), $verbose ); + + my $uptodate = 1; # default return value + + for my $name (qw[auth dslip mod]) { + for my $file ( $conf->_get_source( $name ) ) { + $self->__check_uptodate( + file => File::Spec->catfile( $args->{path}, $file ), + name => $name, + update_source => $update_source, + verbose => $verbose, + ) or $uptodate = 0; + } + } + + return $uptodate; +} + +=pod + +=head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] ) + +C<__check_uptodate> checks if a given source file is still up-to-date +and if not, or when C is true, will re-fetch the source +file. + +Takes the following arguments: + +=over 4 + +=item file + +The source file to check. + +=item name + +The internal shortcut name for the source file (used for config +lookups). + +=item update_source + +Flag to force updating of sourcefiles regardless. + +=item verbose + +Boolean to indicate whether to be verbose or not. + +=back + +Returns a boolean value indicating whether the current files are up +to date or not. + +=cut + +### this method checks whether or not the source files we are using are still up to date +sub __check_uptodate { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + file => { required => 1 }, + name => { required => 1 }, + update_source => { default => 0 }, + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $flag; + unless ( -e $args->{'file'} && ( + ( stat $args->{'file'} )[9] + + $conf->_get_source('update') ) + > time ) { + $flag = 1; + } + + if ( $flag or $args->{'update_source'} ) { + + if ( $self->_update_source( name => $args->{'name'} ) ) { + return 0; # return 0 so 'uptodate' will be set to 0, meaning no use + # of previously stored hashrefs! + } else { + msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} ); + return 1; + } + + } else { + return 1; + } +} + +=pod + +=head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] ) + +This method does the actual fetching of source files. + +It takes the following arguments: + +=over 4 + +=item name + +The internal shortcut name for the source file (used for config +lookups). + +=item path + +The full path where to write the files. + +=item verbose + +Boolean to indicate whether to be verbose or not. + +=back + +Returns a boolean to indicate success. + +=cut + +### this sub fetches new source files ### +sub _update_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + name => { required => 1 }, + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + + my $path = $args->{path}; + my $now = time; + + { ### this could use a clean up - Kane + ### no worries about the / -> we get it from the _ftp configuration, so + ### it's not platform dependant. -kane + my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg; + + msg( loc("Updating source file '%1'", $file), $args->{'verbose'} ); + + my $fake = CPANPLUS::Module::Fake->new( + module => $args->{'name'}, + path => $dir, + package => $file, + _id => $self->_id, + ); + + ### can't use $fake->fetch here, since ->parent won't work -- + ### the sources haven't been saved yet + my $rv = $self->_fetch( + module => $fake, + fetchdir => $path, + force => 1, + ); + + + unless ($rv) { + error( loc("Couldn't fetch '%1'", $file) ); + return; + } + + ### `touch` the file, so windoze knows it's new -jmb + ### works on *nix too, good fix -Kane + utime ( $now, $now, File::Spec->catfile($path, $file) ) or + error( loc("Couldn't touch %1", $file) ); + + } + return 1; +} + +=pod + +=head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] ) + +This method rebuilds the author- and module-trees from source. + +It takes the following arguments: + +=over 4 + +=item uptodate + +Indicates whether any on disk caches are still ok to use. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=item use_stored + +A boolean flag indicating whether or not it is ok to use previously +stored trees. Defaults to true. + +=back + +Returns a boolean indicating success. + +=cut + +### (re)build the trees ### +sub _build_trees { + my ($self, %hash) = @_; + my $conf = $self->configure_object; + + my($path,$uptodate,$use_stored); + my $tmpl = { + path => { default => $conf->get_conf('base'), store => \$path }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { required => 1, store => \$uptodate }, + use_stored => { default => 1, store => \$use_stored }, + }; + + my $args = check( $tmpl, \%hash ) or return undef; + + ### retrieve the stored source files ### + my $stored = $self->__retrieve_source( + path => $path, + uptodate => $uptodate && $use_stored, + verbose => $args->{'verbose'}, + ) || {}; + + ### build the trees ### + $self->{_authortree} = $stored->{_authortree} || + $self->__create_author_tree( + uptodate => $uptodate, + path => $path, + verbose => $args->{verbose}, + ); + $self->{_modtree} = $stored->{_modtree} || + $self->_create_mod_tree( + uptodate => $uptodate, + path => $path, + verbose => $args->{verbose}, + ); + + ### return if we weren't able to build the trees ### + return unless $self->{_modtree} && $self->{_authortree}; + + ### write the stored files to disk, so we can keep using them + ### from now on, till they become invalid + ### write them if the original sources weren't uptodate, or + ### we didn't just load storable files + $self->_save_source() if !$uptodate or not keys %$stored; + + ### still necessary? can only run one instance now ### + ### will probably stay that way --kane +# my $id = $self->_store_id( $self ); +# +# unless ( $id == $self->_id ) { +# error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) ); +# } + + return 1; +} + +=pod + +=head2 $cb->__retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL]) + +This method retrieves a Id tree identified by C<$name>. + +It takes the following arguments: + +=over 4 + +=item name + +The internal name for the source file to retrieve. + +=item uptodate + +A flag indicating whether the file-cache is up-to-date or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +sub __retrieve_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable = can_load( modules => {'Storable' => '0.0'} ) + if $conf->get_conf('storable'); + + return unless $storable; + + ### $stored is the name of the frozen data structure ### + my $stored = $self->__storable_file( $args->{path} ); + + if ($storable && -e $stored && -s _ && $args->{'uptodate'}) { + msg( loc("Retrieving %1", $stored), $args->{'verbose'} ); + + my $href = Storable::retrieve($stored); + return $href; + } else { + return; + } +} + +=pod + +=head2 $cb->_save_source([verbose => BOOL, path => $path]) + +This method saves all the parsed trees in Id format if +C is available. + +It takes the following arguments: + +=over 4 + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns true on success, false on failure. + +=cut + +sub _save_source { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + path => { default => $conf->get_conf('base'), allow => DIR_EXISTS }, + verbose => { default => $conf->get_conf('verbose') }, + force => { default => 1 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $aref = [qw[_modtree _authortree]]; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable; + $storable = can_load( modules => {'Storable' => '0.0'} ) + if $conf->get_conf('storable'); + return unless $storable; + + my $to_write = {}; + foreach my $key ( @$aref ) { + next unless ref( $self->{$key} ); + $to_write->{$key} = $self->{$key}; + } + + return unless keys %$to_write; + + ### $stored is the name of the frozen data structure ### + my $stored = $self->__storable_file( $args->{path} ); + + if (-e $stored && not -w $stored) { + msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} ); + return; + } + + msg( loc("Writing compiled source information to disk. This might take a little while."), + $args->{'verbose'} ); + + my $flag; + unless( Storable::nstore( $to_write, $stored ) ) { + error( loc("could not store %1!", $stored) ); + $flag++; + } + + return $flag ? 0 : 1; +} + +sub __storable_file { + my $self = shift; + my $conf = $self->configure_object; + my $path = shift or return; + + ### check if we can retrieve a frozen data structure with storable ### + my $storable = $conf->get_conf('storable') + ? can_load( modules => {'Storable' => '0.0'} ) + : 0; + + return unless $storable; + + ### $stored is the name of the frozen data structure ### + ### changed to use File::Spec->catfile -jmb + my $stored = File::Spec->rel2abs( + File::Spec->catfile( + $path, #base dir + $conf->_get_source('stored') #file + . '.' . + $Storable::VERSION #the version of storable + . '.stored' #append a suffix + ) + ); + + return $stored; +} + +=pod + +=head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable author-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is uptodate or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +sub __create_author_tree() { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + my $tree = {}; + my $file = File::Spec->catfile( + $args->{path}, + $conf->_get_source('auth') + ); + + msg(loc("Rebuilding author tree, this might take a while"), + $args->{verbose}); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $cont = $self->_get_file_contents( file => $out ) or return; + + ### don't need it anymore ### + unlink $out; + + for ( split /\n/, $cont ) { + my($id, $name, $email) = m/^alias \s+ + (\S+) \s+ + "\s* ([^\"\<]+?) \s* <(.+)> \s*" + /x; + + $tree->{$id} = CPANPLUS::Module::Author->new( + author => $name, #authors name + email => $email, #authors email address + cpanid => $id, #authors CPAN ID + _id => $self->_id, #id of this internals object + ); + } + + return $tree; + +} #__create_author_tree + +=pod + +=head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable module-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is up-to-date or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +### this builds a hash reference with the structure of the cpan module tree ### +sub _create_mod_tree { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return undef; + my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod')); + + msg(loc("Rebuilding module tree, this might take a while"), + $args->{verbose}); + + + my $dslip_tree = $self->__create_dslip_tree( %$args ); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $cont = $self->_get_file_contents( file => $out ) or return; + + ### don't need it anymore ### + unlink $out; + + my $tree = {}; + my $flag; + + for ( split /\n/, $cont ) { + + ### quick hack to read past the header of the file ### + ### this is still rather evil... fix some time - Kane + $flag = 1 if m|^\s*$|; + next unless $flag; + + ### skip empty lines ### + next unless /\S/; + chomp; + + my @data = split /\s+/; + + ### filter out the author and filename as well ### + ### authors can apparently have digits in their names, + ### and dirs can have dots... blah! + my ($author, $package) = $data[2] =~ + m| [A-Z\d-]/ + [A-Z\d-]{2}/ + ([A-Z\d-]+) (?:/[\S]+)?/ + ([^/]+)$ + |xsg; + + ### remove file name from the path + $data[2] =~ s|/[^/]+$||; + + + unless( $self->author_tree($author) ) { + error( loc( "No such author '%1' -- can't make module object " . + "'%2' that is supposed to belong to this author", + $author, $data[0] ) ); + next; + } + + ### adding the dslip info + ### probably can use some optimization + my $dslip; + for my $item ( qw[ statd stats statl stati statp ] ) { + ### checking if there's an entry in the dslip info before + ### catting it on. appeasing warnings this way + $dslip .= $dslip_tree->{ $data[0] }->{$item} + ? $dslip_tree->{ $data[0] }->{$item} + : ' '; + } + + ### Every module get's stored as a module object ### + $tree->{ $data[0] } = CPANPLUS::Module->new( + module => $data[0], # full module name + version => ($data[1] eq 'undef' # version number + ? '0.0' + : $data[1]), + path => File::Spec::Unix->catfile( + $conf->_get_mirror('base'), + $data[2], + ), # extended path on the cpan mirror, + # like /A/AB/ABIGAIL + comment => $data[3], # comment on the module + author => $self->author_tree($author), + package => $package, # package name, like + # 'foo-bar-baz-1.03.tar.gz' + description => $dslip_tree->{ $data[0] }->{'description'}, + dslip => $dslip, + _id => $self->_id, #id of this internals object + ); + + } #for + + return $tree; + +} #_create_mod_tree + +=pod + +=head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL]) + +This method opens a source files and parses its contents into a +searchable dslip-tree or restores a file-cached version of a +previous parse, if the sources are uptodate and the file-cache exists. + +It takes the following arguments: + +=over 4 + +=item uptodate + +A flag indicating whether the file-cache is uptodate or not. + +=item path + +The absolute path to the directory holding the source files. + +=item verbose + +A boolean flag indicating whether or not to be verbose. + +=back + +Will get information from the config file by default. + +Returns a tree on success, false on failure. + +=cut + +sub __create_dslip_tree { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $tmpl = { + path => { default => $conf->get_conf('base') }, + verbose => { default => $conf->get_conf('verbose') }, + uptodate => { default => 0 }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### get the file name of the source ### + my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip')); + + ### extract the file ### + my $ae = Archive::Extract->new( archive => $file ) or return; + my $out = STRIP_GZ_SUFFIX->($file); + + ### make sure to set the PREFER_BIN flag if desired ### + { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin'); + $ae->extract( to => $out ) or return; + } + + my $in = $self->_get_file_contents( file => $out ) or return; + + ### don't need it anymore ### + unlink $out; + + + ### get rid of the comments and the code ### + ### need a smarter parser, some people have this in their dslip info: + # [ + # 'Statistics::LTU', + # 'R', + # 'd', + # 'p', + # 'O', + # '?', + # 'Implements Linear Threshold Units', + # ...skipping... + # "\x{c4}dd \x{fc}ml\x{e4}\x{fc}ts t\x{f6} \x{eb}v\x{eb}r\x{ff}th\x{ef}ng!", + # 'BENNIE', + # '11' + # ], + ### also, older versions say: + ### $cols = [....] + ### and newer versions say: + ### $CPANPLUS::Modulelist::cols = [...] + ### split '$cols' and '$data' into 2 variables ### + ### use this regex to make sure dslips with ';' in them don't cause + ### parser errors + my ($ds_one, $ds_two) = ($in =~ m|.+}\s+ + (\$(?:CPAN::Modulelist::)?cols.*?) + (\$(?:CPAN::Modulelist::)?data.*) + |sx); + + ### eval them into existence ### + ### still not too fond of this solution - kane ### + my ($cols, $data); + { #local $@; can't use this, it's buggy -kane + + $cols = eval $ds_one; + error( loc("Error in eval of dslip source files: %1", $@) ) if $@; + + $data = eval $ds_two; + error( loc("Error in eval of dslip source files: %1", $@) ) if $@; + + } + + my $tree = {}; + my $primary = "modid"; + + ### this comes from CPAN::Modulelist + ### which is in 03modlist.data.gz + for (@$data){ + my %hash; + @hash{@$cols} = @$_; + $tree->{$hash{$primary}} = \%hash; + } + + return $tree; + +} #__create_dslip_tree + +=pod + +=head2 $cb->_dslip_defs () + +This function returns the definition structure (ARRAYREF) of the +dslip tree. + +=cut + +### these are the definitions used for dslip info +### they shouldn't change over time.. so hardcoding them doesn't appear to +### be a problem. if it is, we need to parse 03modlist.data better to filter +### all this out. +### right now, this is just used to look up dslip info from a module +sub _dslip_defs { + my $self = shift; + + my $aref = [ + + # D + [ q|Development Stage|, { + i => loc('Idea, listed to gain consensus or as a placeholder'), + c => loc('under construction but pre-alpha (not yet released)'), + a => loc('Alpha testing'), + b => loc('Beta testing'), + R => loc('Released'), + M => loc('Mature (no rigorous definition)'), + S => loc('Standard, supplied with Perl 5'), + }], + + # S + [ q|Support Level|, { + m => loc('Mailing-list'), + d => loc('Developer'), + u => loc('Usenet newsgroup comp.lang.perl.modules'), + n => loc('None known, try comp.lang.perl.modules'), + a => loc('Abandoned; volunteers welcome to take over maintainance'), + }], + + # L + [ q|Language Used|, { + p => loc('Perl-only, no compiler needed, should be platform independent'), + c => loc('C and perl, a C compiler will be needed'), + h => loc('Hybrid, written in perl with optional C code, no compiler needed'), + '+' => loc('C++ and perl, a C++ compiler will be needed'), + o => loc('perl and another language other than C or C++'), + }], + + # I + [ q|Interface Style|, { + f => loc('plain Functions, no references used'), + h => loc('hybrid, object and function interfaces available'), + n => loc('no interface at all (huh?)'), + r => loc('some use of unblessed References or ties'), + O => loc('Object oriented using blessed references and/or inheritance'), + }], + + # P + [ q|Public License|, { + p => loc('Standard-Perl: user may choose between GPL and Artistic'), + g => loc('GPL: GNU General Public License'), + l => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'), + b => loc('BSD: The BSD License'), + a => loc('Artistic license alone'), + o => loc('other (but distribution allowed without restrictions)'), + }], + ]; + + return $aref; +} + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +1; diff --git a/lib/CPANPLUS/Internals/Utils.pm b/lib/CPANPLUS/Internals/Utils.pm new file mode 100644 index 0000000..6251608 --- /dev/null +++ b/lib/CPANPLUS/Internals/Utils.pm @@ -0,0 +1,536 @@ +package CPANPLUS::Internals::Utils; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use Cwd; +use File::Copy; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Internals::Utils + +=head1 SYNOPSIS + + my $bool = $cb->_mkdir( dir => 'blah' ); + my $bool = $cb->_chdir( dir => 'blah' ); + my $bool = $cb->_rmdir( dir => 'blah' ); + + my $bool = $cb->_move( from => '/some/file', to => '/other/file' ); + my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' ); + + my $cont = $cb->_get_file_contents( file => '/path/to/file' ); + + + my $version = $cb->_perl_version( perl => $^X ); + +=head1 DESCRIPTION + +C holds a few convenience functions for +CPANPLUS libraries. + +=head1 METHODS + +=head2 $cb->_mkdir( dir => '/some/dir' ) + +C<_mkdir> creates a full path to a directory. + +Returns true on success, false on failure. + +=cut + +sub _mkdir { + my $self = shift; + + my %hash = @_; + + my $tmpl = { + dir => { required => 1 }, + }; + + my $args = check( $tmpl, \%hash ) or ( + error(loc( Params::Check->last_error ) ), return + ); + + unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { + error( loc("Could not use File::Path! This module should be core!") ); + return; + } + + eval { File::Path::mkpath($args->{dir}) }; + + if($@) { + chomp($@); + error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ )); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_chdir( dir => '/some/dir' ) + +C<_chdir> changes directory to a dir. + +Returns true on success, false on failure. + +=cut + +sub _chdir { + my $self = shift; + my %hash = @_; + + my $tmpl = { + dir => { required => 1, allow => DIR_EXISTS }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + unless( chdir $args->{dir} ) { + error( loc(q[Could not chdir into '%1'], $args->{dir}) ); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_rmdir( dir => '/some/dir' ); + +Removes a directory completely, even if it is non-empty. + +Returns true on success, false on failure. + +=cut + +sub _rmdir { + my $self = shift; + my %hash = @_; + + my $tmpl = { + dir => { required => 1, allow => IS_DIR }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { + error( loc("Could not use File::Path! This module should be core!") ); + return; + } + + eval { File::Path::rmtree($args->{dir}) }; + + if($@) { + chomp($@); + error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ )); + return; + } + + return 1; +} + +=pod + +=head2 $cb->_perl_version ( perl => 'some/perl/binary' ); + +C<_perl_version> returns the version of a certain perl binary. +It does this by actually running a command. + +Returns the perl version on success and false on failure. + +=cut + +sub _perl_version { + my $self = shift; + my %hash = @_; + + my $perl; + my $tmpl = { + perl => { required => 1, store => \$perl }, + }; + + check( $tmpl, \%hash ) or return; + + my $perl_version; + ### special perl, or the one we are running under? + if( $perl eq $^X ) { + ### just load the config + require Config; + $perl_version = $Config::Config{version}; + + } else { + my $cmd = $perl . + ' -MConfig -eprint+Config::config_vars+version'; + ($perl_version) = (`$cmd` =~ /version='(.*)'/); + } + + return $perl_version if defined $perl_version; + return; +} + +=pod + +=head2 $cb->_version_to_number( version => $version ); + +Returns a proper module version, or '0.0' if none was available. + +=cut + +sub _version_to_number { + my $self = shift; + my %hash = @_; + + my $version; + my $tmpl = { + version => { default => '0.0', store => \$version }, + }; + + check( $tmpl, \%hash ) or return; + + return $version if $version =~ /^\.?\d/; + return '0.0'; +} + +=pod + +=head2 $cb->_whoami + +Returns the name of the subroutine you're currently in. + +=cut + +sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name } + +=pod + +=head2 _get_file_contents( file => $file ); + +Returns the contents of a file + +=cut + +sub _get_file_contents { + my $self = shift; + my %hash = @_; + + my $file; + my $tmpl = { + file => { required => 1, store => \$file } + }; + + check( $tmpl, \%hash ) or return; + + my $fh = OPEN_FILE->($file) or return; + my $contents = do { local $/; <$fh> }; + + return $contents; +} + +=pod $cb->_move( from => $file|$dir, to => $target ); + +Moves a file or directory to the target. + +Returns true on success, false on failure. + +=cut + +sub _move { + my $self = shift; + my %hash = @_; + + my $from; my $to; + my $tmpl = { + file => { required => 1, allow => [IS_FILE,IS_DIR], + store => \$from }, + to => { required => 1, store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + if( File::Copy::move( $from, $to ) ) { + return 1; + } else { + error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!)); + return; + } +} + +=pod $cb->_copy( from => $file|$dir, to => $target ); + +Moves a file or directory to the target. + +Returns true on success, false on failure. + +=cut + +sub _copy { + my $self = shift; + my %hash = @_; + + my($from,$to); + my $tmpl = { + file =>{ required => 1, allow => [IS_FILE,IS_DIR], + store => \$from }, + to => { required => 1, store => \$to } + }; + + check( $tmpl, \%hash ) or return; + + if( File::Copy::copy( $from, $to ) ) { + return 1; + } else { + error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!)); + return; + } +} + +=head2 $cb->_mode_plus_w( file => '/path/to/file' ); + +Sets the +w bit for the file. + +Returns true on success, false on failure. + +=cut + +sub _mode_plus_w { + my $self = shift; + my %hash = @_; + + require File::stat; + + my $file; + my $tmpl = { + file => { required => 1, allow => IS_FILE, store => \$file }, + }; + + check( $tmpl, \%hash ) or return; + + ### set the mode to +w for a file and +wx for a dir + my $x = File::stat::stat( $file ); + my $mask = -d $file ? 0100 : 0200; + + if( $x and chmod( $x->mode|$mask, $file ) ) { + return 1; + + } else { + error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!)); + return; + } +} + +=head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH ); + +Turns a CPANPLUS::Config style C entry into an URI string. + +Returns the uri on success, and false on failure + +=cut + +sub _host_to_uri { + my $self = shift; + my %hash = @_; + + my($scheme, $host, $path); + my $tmpl = { + scheme => { required => 1, store => \$scheme }, + host => { default => '', store => \$host }, + path => { default => '', store => \$path }, + }; + + check( $tmpl, \%hash ) or return; + + $host ||= 'localhost'; + + return "$scheme://" . File::Spec::Unix->catdir( $host, $path ); +} + +=head2 $cb->_vcmp( VERSION, VERSION ); + +Normalizes the versions passed and does a '<=>' on them, returning the result. + +=cut + +sub _vcmp { + my $self = shift; + my ($x, $y) = @_; + + s/_//g foreach $x, $y; + + return $x <=> $y; +} + +=head2 $cb->_home_dir + +Returns the user's homedir, or C if it could not be found + +=cut + +sub _home_dir { + my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN ); + + for my $env ( @os_home_envs ) { + next unless exists $ENV{ $env }; + next unless defined $ENV{ $env } && length $ENV{ $env }; + return $ENV{ $env } if -d $ENV{ $env }; + } + + return cwd(); +} + +=head2 $path = $cb->_safe_path( path => $path ); + +Returns a path that's safe to us on Win32. Only cleans up +the path on Win32 if the path exists. + +=cut + +sub _safe_path { + my $self = shift; + + my %hash = @_; + + my $path; + my $tmpl = { + path => { required => 1, store => \$path }, + }; + + check( $tmpl, \%hash ) or return; + + ### only need to fix it up if there's spaces in the path + return $path unless $path =~ /\s+/; + + ### or if we are on win32 + return $path if $^O ne 'MSWin32'; + + ### clean up paths if we are on win32 + return Win32::GetShortPathName( $path ) || $path; + +} + + +=head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING ); + +Splits the name of a CPAN package string up in it's package, version +and extension parts. + +For example, C would return the following parts: + + Package: Foo-Bar + Version: 1.2 + Extension: tar.gz + +=cut + +{ my $del_re = qr/[-_\+]/i; # delimiter between elements + my $pkg_re = qr/[a-z] # any letters followed by + [a-z\d]* # any letters, numbers + (?i:\.pm)? # followed by '.pm'--authors do this :( + (?: # optionally repeating: + $del_re # followed by a delimiter + [a-z] # any letters followed by + [a-z\d]* # any letters, numbers + (?i:\.pm)? # followed by '.pm'--authors do this :( + )* + /xi; + + my $ver_re = qr/[a-z]*\d+[a-z]* # contains a digit and possibly letters + (?: + [-._] # followed by a delimiter + [a-z\d]+ # and more digits and or letters + )*? + /xi; + + my $ext_re = qr/[a-z] # a letter, followed by + [a-z\d]* # letters and or digits, optionally + (?: + \. # followed by a dot and letters + [a-z\d]+ # and or digits (like .tar.bz2) + )? # optionally + /xi; + + my $ver_ext_re = qr/ + ($ver_re+) # version, optional + (?: + \. # a literal . + ($ext_re) # extension, + )? # optional, but requires version + /xi; + + ### composed regex for CPAN packages + my $full_re = qr/ + ^ + ($pkg_re+) # package + (?: + $del_re # delimiter + $ver_ext_re # version + extension + )? + $ + /xi; + + ### composed regex for perl packages + my $perl = PERL_CORE; + my $perl_re = qr/ + ^ + ($perl) # package name for 'perl' + (?: + $ver_ext_re # version + extension + )? + $ + /xi; + + +sub _split_package_string { + my $self = shift; + my %hash = @_; + + my $str; + my $tmpl = { package => { required => 1, store => \$str } }; + check( $tmpl, \%hash ) or return; + + + ### 2 different regexes, one for the 'perl' package, + ### one for ordinary CPAN packages.. try them both, + ### first match wins. + for my $re ( $full_re, $perl_re ) { + + ### try the next if the match fails + $str =~ $re or next; + + my $pkg = $1 || ''; + my $ver = $2 || ''; + my $ext = $3 || ''; + + ### this regex resets the capture markers! + ### strip the trailing delimiter + $pkg =~ s/$del_re$//; + + ### strip the .pm package suffix some authors insist on adding + $pkg =~ s/\.pm$//i; + + return ($pkg, $ver, $ext ); + } + + return; + } +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Internals/Utils/Autoflush.pm b/lib/CPANPLUS/Internals/Utils/Autoflush.pm new file mode 100644 index 0000000..5656643 --- /dev/null +++ b/lib/CPANPLUS/Internals/Utils/Autoflush.pm @@ -0,0 +1,5 @@ +package CPANPLUS::Internals::Utils::Autoflush; + +BEGIN { $|++ }; + +1; diff --git a/lib/CPANPLUS/Module.pm b/lib/CPANPLUS/Module.pm new file mode 100644 index 0000000..96030d3 --- /dev/null +++ b/lib/CPANPLUS/Module.pm @@ -0,0 +1,1580 @@ +package CPANPLUS::Module; + +use strict; +use vars qw[@ISA]; + + +use CPANPLUS::Dist; +use CPANPLUS::Error; +use CPANPLUS::Module::Signature; +use CPANPLUS::Module::Checksums; +use CPANPLUS::Internals::Constants; + +use FileHandle; + +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use IPC::Cmd qw[can_run run]; +use File::Find qw[find]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; + +$Params::Check::VERBOSE = 1; + +@ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums]; + +=pod + +=head1 NAME + +CPANPLUS::Module + +=head1 SYNOPSIS + + ### get a module object from the CPANPLUS::Backend object + my $mod = $cb->module_tree('Some::Module'); + + ### accessors + $mod->version; + $mod->package; + + ### methods + $mod->fetch; + $mod->extract; + $mod->install; + + +=head1 DESCRIPTION + +C creates objects from the information in the +source files. These can then be used to query and perform actions +on, like fetching or installing. + +These objects should only be created internally. For C objects, +there's the C class. To obtain a module object +consult the C documentation. + +=cut + +my $tmpl = { + module => { default => '', required => 1 }, # full module name + version => { default => '0.0' }, # version number + path => { default => '', required => 1 }, # extended path on the + # cpan mirror, like + # /author/id/K/KA/KANE + comment => { default => ''}, # comment on module + package => { default => '', required => 1 }, # package name, like + # 'bar-baz-1.03.tgz' + description => { default => '' }, # description of the + # module + dslip => { default => ' ' }, # dslip information + _id => { required => 1 }, # id of the Internals + # parent object + _status => { no_override => 1 }, # stores status object + author => { default => '', required => 1, + allow => IS_AUTHOBJ }, # module author + mtime => { default => '' }, +}; + +### autogenerate accessors ### +for my $key ( keys %$tmpl ) { + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + $_[0]->{$key} = $_[1] if @_ > 1; + return $_[0]->{$key}; + } +} + +=pod + +=head1 CLASS METHODS + +=head2 accessors () + +Returns a list of all accessor methods to the object + +=cut + +### *name is an alias, include it explicitly +sub accessors { return ('name', keys %$tmpl) }; + +=head1 ACCESSORS + +An objects of this class has the following accessors: + +=over 4 + +=item name + +Name of the module. + +=item module + +Name of the module. + +=item version + +Version of the module. Defaults to '0.0' if none was provided. + +=item path + +Extended path on the mirror. + +=item comment + +Any comment about the module -- largely unused. + +=item package + +The name of the package. + +=item description + +Description of the module -- only registered modules have this. + +=item dslip + +The five character dslip string, that represents meta-data of the +module -- again, only registered modules have this. + +=item status + +The C object associated with this object. +(see below). + +=item author + +The C object associated with this object. + +=item parent + +The C object that spawned this module object. + +=back + +=cut + +### Alias ->name to ->module, for human beings. +*name = *module; + +sub parent { + my $self = shift; + my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id ); + + return $obj; +} + +=head1 STATUS ACCESSORS + +C caches a lot of results from method calls and saves data +it collected along the road for later reuse. + +C uses this internally, but it is also available for the end +user. You can get a status object by calling: + + $modobj->status + +You can then query the object as follows: + +=over 4 + +=item installer_type + +The installer type used for this distribution. Will be one of +'makemaker' or 'build'. This determines whether C +or C will be used to build this distribution. + +=item dist_cpan + +The dist object used to do the CPAN-side of the installation. Either +a C or C object. + +=item dist + +The custom dist object used to do the operating specific side of the +installation, if you've chosen to use this. For example, if you've +chosen to install using the C format, this may be a +C object. + +Undefined if you didn't specify a separate format to install through. + +=item prereqs + +A hashref of prereqs this distribution was found to have. Will look +something like this: + + { Carp => 0.01, strict => 0 } + +Might be undefined if the distribution didn't have any prerequisites. + +=item signature + +Flag indicating, if a signature check was done, whether it was OK or +not. + +=item extract + +The directory this distribution was extracted to. + +=item fetch + +The location this distribution was fetched to. + +=item readme + +The text of this distributions README file. + +=item uninstall + +Flag indicating if an uninstall call was done successfully. + +=item created + +Flag indicating if the C call to your dist object was done +successfully. + +=item installed + +Flag indicating if the C call to your dist object was done +successfully. + +=item checksums + +The location of this distributions CHECKSUMS file. + +=item checksum_ok + +Flag indicating if the checksums check was done successfully. + +=item checksum_value + +The checksum value this distribution is expected to have + +=back + +=head1 METHODS + +=head2 $self = CPANPLUS::Module::new( OPTIONS ) + +This method returns a C object. Normal users +should never call this method directly, but instead use the +C to obtain module objects. + +This example illustrates a C call with all required arguments: + + CPANPLUS::Module->new( + module => 'Foo', + path => 'authors/id/A/AA/AAA', + package => 'Foo-1.0.tgz', + author => $author_object, + _id => INTERNALS_OBJECT_ID, + ); + +Every accessor is also a valid option to pass to C. + +Returns a module object on success and false on failure. + +=cut + + +sub new { + my($class, %hash) = @_; + + ### don't check the template for sanity + ### -- we know it's good and saves a lot of performance + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + + my $object = check( $tmpl, \%hash ) or return; + + bless $object, $class; + + return $object; +} + +### only create status objects when they're actually asked for +sub status { + my $self = shift; + return $self->_status if $self->_status; + + my $acc = Object::Accessor->new; + $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs + signature extract fetch readme uninstall + created installed prepared checksums files + checksum_ok checksum_value _fetch_from] ); + + $self->_status( $acc ); + + return $self->_status; +} + + +### flush the cache of this object ### +sub _flush { + my $self = shift; + $self->status->mk_flush; + return 1; +} + +=head2 $mod->package_name + +Returns the name of the package a module is in. For C +that might be C. + +=head2 $mod->package_version + +Returns the version of the package a module is in. For a module +in the package C this would be C<1.1>. + +=head2 $mod->package_extension + +Returns the suffix added by the compression method of a package a +certain module is in. For a module in C, this +would be C. + +=head2 $mod->package_is_perl_core + +Returns a boolean indicating of the package a particular module is in, +is actually a core perl distribution. + +=head2 $mod->module_is_supplied_with_perl_core( [version => $]] ) + +Returns a boolean indicating whether C of this module +was supplied with the current running perl's core package. + +=head2 $mod->is_bundle + +Returns a boolean indicating if the module you are looking at, is +actually a bundle. Bundles are identified as modules whose name starts +with C. + +=head2 $mod->is_third_party + +Returns a boolean indicating whether the package is a known third-party +module (i.e. it's not provided by the standard Perl distribution and +is not available on the CPAN, but on a third party software provider). +See L for more details. + +=head2 $mod->third_party_information + +Returns a reference to a hash with more information about a third-party +module. See the documentation about C in +L for more details. + +=cut + +{ ### fetches the test reports for a certain module ### + my %map = ( + name => 0, + version => 1, + extension => 2, + ); + + while ( my($type, $index) = each %map ) { + my $name = 'package_' . $type; + + no strict 'refs'; + *$name = sub { + my $self = shift; + my @res = $self->parent->_split_package_string( + package => $self->package + ); + + ### return the corresponding index from the result + return $res[$index] if @res; + return; + }; + } + + sub package_is_perl_core { + my $self = shift; + + ### check if the package looks like a perl core package + return 1 if $self->package_name eq PERL_CORE; + + my $core = $self->module_is_supplied_with_perl_core; + ### ok, so it's found in the core, BUT it could be dual-lifed + if ($core) { + ### if the package is newer than installed, then it's dual-lifed + return if $self->version > $self->installed_version; + + ### if the package is newer or equal to the corelist, + ### then it's dual-lifed + return if $self->version >= $core; + + ### otherwise, it's older than corelist, thus unsuitable. + return 1; + } + + ### not in corelist, not a perl core package. + return; + } + + sub module_is_supplied_with_perl_core { + my $self = shift; + my $ver = shift || $]; + + ### check Module::CoreList to see if it's a core package + require Module::CoreList; + my $core = $Module::CoreList::version{ $ver }->{ $self->module }; + + return $core; + } + + ### make sure Bundle-Foo also gets flagged as bundle + sub is_bundle { + return shift->module =~ /^bundle(?:-|::)/i ? 1 : 0; + } + + sub is_third_party { + my $self = shift; + + return unless can_load( modules => { 'Module::ThirdParty' => 0 } ); + + return Module::ThirdParty::is_3rd_party( $self->name ); + } + + sub third_party_information { + my $self = shift; + + return unless $self->is_third_party; + + return Module::ThirdParty::module_information( $self->name ); + } +} + +=pod + +=head2 $clone = $self->clone + +Clones the current module object for tinkering with. +It will have a clean C object, as well as +a fake C object. + +=cut + +sub clone { + my $self = shift; + + ### clone the object ### + my %data; + for my $acc ( grep !/status/, __PACKAGE__->accessors() ) { + $data{$acc} = $self->$acc(); + } + + my $obj = CPANPLUS::Module::Fake->new( %data ); + + return $obj; +} + +=pod + +=head2 $where = $self->fetch + +Fetches the module from a CPAN mirror. +Look at L for details on the +options you can pass. + +=cut + +sub fetch { + my $self = shift; + my $cb = $self->parent; + + ### custom args + my %args = ( module => $self ); + + ### if a custom fetch location got specified before, add that here + $args{fetch_from} = $self->status->_fetch_from + if $self->status->_fetch_from; + + my $where = $cb->_fetch( @_, %args ) or return; + + ### do an md5 check ### + if( !$self->status->_fetch_from and + $cb->configure_object->get_conf('md5') and + $self->package ne CHECKSUMS + ) { + unless( $self->_validate_checksum ) { + error( loc( "Checksum error for '%1' -- will not trust package", + $self->package) ); + return; + } + } + + return $where; +} + +=pod + +=head2 $path = $self->extract + +Extracts the fetched module. +Look at L for details on +the options you can pass. + +=cut + +sub extract { + my $self = shift; + my $cb = $self->parent; + + unless( $self->status->fetch ) { + error( loc( "You have not fetched '%1' yet -- cannot extract", + $self->module) ); + return; + } + + return $cb->_extract( @_, module => $self ); +} + +=head2 $type = $self->get_installer_type([prefer_makefile => BOOL]) + +Gets the installer type for this module. This may either be C or +C. If C is unavailable or no installer type +is available, it will fall back to C. If both are available, +it will pick the one indicated by your config, or by the +C option you can pass to this function. + +Returns the installer type on success, and false on error. + +=cut + +sub get_installer_type { + my $self = shift; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $prefer_makefile; + my $tmpl = { + prefer_makefile => { default => $conf->get_conf('prefer_makefile'), + store => \$prefer_makefile, allow => BOOLEANS }, + }; + + check( $tmpl, \%hash ) or return; + + my $extract = $self->status->extract(); + unless( $extract ) { + error(loc("Cannot determine installer type of unextracted module '%1'", + $self->module)); + return; + } + + + ### check if it's a makemaker or a module::build type dist ### + my $found_build = -e BUILD_PL->( $extract ); + my $found_makefile = -e MAKEFILE_PL->( $extract ); + + my $type; + $type = INSTALLER_BUILD if !$prefer_makefile && $found_build; + $type = INSTALLER_BUILD if $found_build && !$found_makefile; + $type = INSTALLER_MM if $prefer_makefile && $found_makefile; + $type = INSTALLER_MM if $found_makefile && !$found_build; + + ### ok, so it's a 'build' installer, but you don't /have/ module build + if( $type eq INSTALLER_BUILD and ( + not grep { $_ eq INSTALLER_BUILD } CPANPLUS::Dist->dist_types ) + ) { + error( loc( "This module requires '%1' and '%2' to be installed, ". + "but you don't have it! Will fall back to ". + "'%3', but might not be able to install!", + 'Module::Build', INSTALLER_BUILD, INSTALLER_MM ) ); + $type = INSTALLER_MM; + + ### ok, actually we found neither ### + } elsif ( !$type ) { + error( loc( "Unable to find '%1' or '%2' for '%3'; ". + "Will default to '%4' but might be unable ". + "to install!", BUILD_PL->(), MAKEFILE_PL->(), + $self->module, INSTALLER_MM ) ); + $type = INSTALLER_MM; + } + + return $self->status->installer_type( $type ) if $type; + return; +} + +=pod + +=head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]); + +Create a distribution object, ready to be installed. +Distribution type defaults to your config settings + +The optional C hashref is passed on to the specific distribution +types' C method after being dereferenced. + +Returns a distribution object on success, false on failure. + +See C for details. + +=cut + +sub dist { + my $self = shift; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + ### have you determined your installer type yet? if not, do it here, + ### we need the info + $self->get_installer_type unless $self->status->installer_type; + + + my($type,$args,$target); + my $tmpl = { + format => { default => $conf->get_conf('dist_type') || + $self->status->installer_type, + store => \$type }, + target => { default => TARGET_CREATE, store => \$target }, + args => { default => {}, store => \$args }, + }; + + check( $tmpl, \%hash ) or return; + + my $dist = CPANPLUS::Dist->new( + format => $type, + module => $self + ) or return; + + my $dist_cpan = $type eq $self->status->installer_type + ? $dist + : CPANPLUS::Dist->new( + format => $self->status->installer_type, + module => $self, + ); + + ### store the dists + $self->status->dist_cpan( $dist_cpan ); + $self->status->dist( $dist ); + + DIST: { + ### first prepare the dist + $dist->prepare( %$args ) or return; + $self->status->prepared(1); + + ### you just wanted us to prepare? + last DIST if $target eq TARGET_PREPARE; + + $dist->create( %$args ) or return; + $self->status->created(1); + } + + return $dist; +} + +=pod + +=head2 $bool = $mod->prepare( ) + +Convenience method around C that prepares a module +without actually building it. This is equivalent to invoking C +with C set to C + +Returns true on success, false on failure. + +=cut + +sub prepare { + my $self = shift; + return $self->install( @_, target => TARGET_PREPARE ); +} + +=head2 $bool = $mod->create( ) + +Convenience method around C that creates a module. +This is equivalent to invoking C with C set to +C + +Returns true on success, false on failure. + +=cut + +sub create { + my $self = shift; + return $self->install( @_, target => TARGET_CREATE ); +} + +=head2 $bool = $mod->test( ) + +Convenience wrapper around C that tests a module, without +installing it. +It's the equivalent to invoking C with C set to +C and C set to C<0>. + +Returns true on success, false on failure. + +=cut + +sub test { + my $self = shift; + return $self->install( @_, target => TARGET_CREATE, skiptest => 0 ); +} + +=pod + +=head2 $bool = $self->install([ target => 'prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]); + +Installs the current module. This includes fetching it and extracting +it, if this hasn't been done yet, as well as creating a distribution +object for it. + +This means you can pass it more arguments than described above, which +will be passed on to the relevant methods as they are called. + +See C, C and +C for details. + +Returns true on success, false on failure. + +=cut + +sub install { + my $self = shift; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $args; my $target; my $format; + { ### so we can use the rest of the args to the create calls etc ### + local $Params::Check::NO_DUPLICATES = 1; + local $Params::Check::ALLOW_UNKNOWN = 1; + + ### targets 'dist' and 'test' are now completely ignored ### + my $tmpl = { + ### match this allow list with Dist->_resolve_prereqs + target => { default => TARGET_INSTALL, store => \$target, + allow => [TARGET_PREPARE, TARGET_CREATE, + TARGET_INSTALL] }, + force => { default => $conf->get_conf('force'), }, + verbose => { default => $conf->get_conf('verbose'), }, + format => { default => $conf->get_conf('dist_type'), + store => \$format }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + + ### if this target isn't 'install', we will need to at least 'create' + ### every prereq, so it can build + ### XXX prereq_target of 'prepare' will do weird things here, and is + ### not supported. + $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL; + + ### check if it's already upto date ### + if( $target eq TARGET_INSTALL and !$args->{'force'} and + !$self->package_is_perl_core() and # separate rules apply + ( $self->status->installed() or $self->is_uptodate ) and + !INSTALL_VIA_PACKAGE_MANAGER->($format) + ) { + msg(loc("Module '%1' already up to date, won't install without force", + $self->module), $args->{'verbose'} ); + return $self->status->installed(1); + } + + # if it's a non-installable core package, abort the install. + if( $self->package_is_perl_core() ) { + # if the installed is newer, say so. + if( $self->installed_version > $self->version ) { + error(loc("The core Perl %1 module '%2' (%3) is more ". + "recent than the latest release on CPAN (%4). ". + "Aborting install.", + $], $self->module, $self->installed_version, + $self->version ) ); + # if the installed matches, say so. + } elsif( $self->installed_version == $self->version ) { + error(loc("The core Perl %1 module '%2' (%3) can only ". + "be installed by Perl itself. ". + "Aborting install.", + $], $self->module, $self->installed_version ) ); + # otherwise, the installed is older; say so. + } else { + error(loc("The core Perl %1 module '%2' can only be ". + "upgraded from %3 to %4 by Perl itself (%5). ". + "Aborting install.", + $], $self->module, $self->installed_version, + $self->version, $self->package ) ); + } + return; + + ### it might be a known 3rd party module + } elsif ( $self->is_third_party ) { + my $info = $self->third_party_information; + error(loc( + "%1 is a known third-party module.\n\n". + "As it isn't available on the CPAN, CPANPLUS can't install " . + "it automatically. Therefore you need to install it manually " . + "before proceeding.\n\n". + "%2 is part of %3, published by %4, and should be available ". + "for download at the following address:\n\t%5", + $self->name, $self->name, $info->{name}, $info->{author}, + $info->{url} + )); + + return; + } + + ### fetch it if need be ### + unless( $self->status->fetch ) { + my $params; + for (qw[prefer_bin fetchdir]) { + $params->{$_} = $args->{$_} if exists $args->{$_}; + } + for (qw[force verbose]) { + $params->{$_} = $args->{$_} if defined $args->{$_}; + } + $self->fetch( %$params ) or return; + } + + ### extract it if need be ### + unless( $self->status->extract ) { + my $params; + for (qw[prefer_bin extractdir]) { + $params->{$_} = $args->{$_} if exists $args->{$_}; + } + for (qw[force verbose]) { + $params->{$_} = $args->{$_} if defined $args->{$_}; + } + $self->extract( %$params ) or return; + } + + $format ||= $self->status->installer_type; + + unless( $format ) { + error( loc( "Don't know what installer to use; " . + "Couldn't find either '%1' or '%2' in the extraction " . + "directory '%3' -- will be unable to install", + BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) ); + + $self->status->installed(0); + return; + } + + + ### do SIGNATURE checks? ### + if( $conf->get_conf('signature') ) { + unless( $self->check_signature( verbose => $args->{verbose} ) ) { + error( loc( "Signature check failed for module '%1' ". + "-- Not trusting this module, aborting install", + $self->module ) ); + $self->status->signature(0); + + ### send out test report on broken sig + if( $conf->get_conf('cpantest') ) { + $cb->_send_report( + module => $self, + failed => 1, + buffer => CPANPLUS::Error->stack_as_string, + verbose => $args->{verbose}, + force => $args->{force}, + ) or error(loc("Failed to send test report for '%1'", + $self->module ) ); + } + + return; + + } else { + ### signature OK ### + $self->status->signature(1); + } + } + + ### a target of 'create' basically means not to run make test ### + ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1. + #$args->{'skiptest'} = 1 if $target eq 'create'; + + ### bundle rules apply ### + if( $self->is_bundle ) { + ### check what we need to install ### + my @prereqs = $self->bundle_modules(); + unless( @prereqs ) { + error( loc( "Bundle '%1' does not specify any modules to install", + $self->module ) ); + + ### XXX mark an error here? ### + } + } + + my $dist = $self->dist( format => $format, + target => $target, + args => $args ); + unless( $dist ) { + error( loc( "Unable to create a new distribution object for '%1' " . + "-- cannot continue", $self->module ) ); + return; + } + + return 1 if $target ne TARGET_INSTALL; + + my $ok = $dist->install( %$args ) ? 1 : 0; + + $self->status->installed($ok); + + return 1 if $ok; + return; +} + +=pod @list = $self->bundle_modules() + +Returns a list of module objects the Bundle specifies. + +This requires you to have extracted the bundle already, using the +C method. + +Returns false on error. + +=cut + +sub bundle_modules { + my $self = shift; + my $cb = $self->parent; + + unless( $self->is_bundle ) { + error( loc("'%1' is not a bundle", $self->module ) ); + return; + } + + my $dir; + unless( $dir = $self->status->extract ) { + error( loc("Don't know where '%1' was extracted to", $self->module ) ); + return; + } + + my @files; + find( { + wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i; }, + no_chdir => 1, + }, $dir ); + + my $prereqs = {}; my @list; my $seen = {}; + for my $file ( @files ) { + my $fh = FileHandle->new($file) + or( error(loc("Could not open '%1' for reading: %2", + $file,$!)), next ); + + my $flag; + while(<$fh>) { + ### quick hack to read past the header of the file ### + last if $flag && m|^=head|i; + + ### from perldoc cpan: + ### =head1 CONTENTS + ### In this pod section each line obeys the format + ### Module_Name [Version_String] [- optional text] + $flag = 1 if m|^=head1 CONTENTS|i; + + if ($flag && /^(?!=)(\S+)\s*(\S+)?/) { + my $module = $1; + my $version = $2 || '0'; + + my $obj = $cb->module_tree($module); + + unless( $obj ) { + error(loc("Cannot find bundled module '%1'", $module), + loc("-- it does not seem to exist") ); + next; + } + + ### make sure we list no duplicates ### + unless( $seen->{ $obj->module }++ ) { + push @list, $obj; + $prereqs->{ $module } = + $cb->_version_to_number( version => $version ); + } + } + } + } + + ### store the prereqs we just found ### + $self->status->prereqs( $prereqs ); + + return @list; +} + +=pod + +=head2 $text = $self->readme + +Fetches the readme belonging to this module and stores it under +C<< $obj->status->readme >>. Returns the readme as a string on +success and returns false on failure. + +=cut + +sub readme { + my $self = shift; + my $conf = $self->parent->configure_object; + + ### did we already dl the readme once? ### + return $self->status->readme() if $self->status->readme(); + + ### this should be core ### + return unless can_load( modules => { FileHandle => '0.0' }, + verbose => 1, + ); + + ### get a clone of the current object, with a fresh status ### + my $obj = $self->clone or return; + + ### munge the package name + my $pkg = README->( $obj ); + $obj->package($pkg); + + my $file; + { ### disable checksum fetches on readme downloads + + my $tmp = $conf->get_conf( 'md5' ); + $conf->set_conf( md5 => 0 ); + + $file = $obj->fetch; + + $conf->set_conf( md5 => $tmp ); + + return unless $file; + } + + ### read the file into a scalar, to store in the original object ### + my $fh = new FileHandle; + unless( $fh->open($file) ) { + error( loc( "Could not open file '%1': %2", $file, $! ) ); + return; + } + + my $in; + { local $/; $in = <$fh> }; + $fh->close; + + return $self->status->readme( $in ); +} + +=pod + +=head2 $version = $self->installed_version() + +Returns the currently installed version of this module, if any. + +=head2 $where = $self->installed_file() + +Returns the location of the currently installed file of this module, +if any. + +=head2 $bool = $self->is_uptodate([version => VERSION_NUMBER]) + +Returns a boolean indicating if this module is uptodate or not. + +=cut + +### uptodate/installed functions +{ my $map = { # hashkey, alternate rv + installed_version => ['version', 0 ], + installed_file => ['file', ''], + is_uptodate => ['uptodate', 0 ], + }; + + while( my($method, $aref) = each %$map ) { + my($key,$alt_rv) = @$aref; + + no strict 'refs'; + *$method = sub { + ### never use the @INC hooks to find installed versions of + ### modules -- they're just there in case they're not on the + ### perl install, but the user shouldn't trust them for *other* + ### modules! + ### XXX CPANPLUS::inc is now obsolete, so this should not + ### be needed anymore + #local @INC = CPANPLUS::inc->original_inc; + + my $self = shift; + + ### make sure check_install is not looking in %INC, as + ### that may contain some of our sneakily loaded modules + ### that aren't installed as such. -- kane + local $Module::Load::Conditional::CHECK_INC_HASH = 0; + my $href = check_install( + module => $self->module, + version => $self->version, + @_, + ); + + return $href->{$key} || $alt_rv; + } + } +} + + + +=pod + +=head2 $href = $self->details() + +Returns a hashref with key/value pairs offering more information about +a particular module. For example, for C it might look like +this: + + Author Jarkko Hietaniemi (jhi@iki.fi) + Description High resolution time, sleep, and alarm + Development Stage Released + Installed File /usr/local/perl/lib/Time/Hires.pm + Interface Style plain Functions, no references used + Language Used C and perl, a C compiler will be needed + Package Time-HiRes-1.65.tar.gz + Public License Unknown + Support Level Developer + Version Installed 1.52 + Version on CPAN 1.65 + +=cut + +sub details { + my $self = shift; + my $conf = $self->parent->configure_object(); + my $cb = $self->parent; + my %hash = @_; + + my $res = { + Author => loc("%1 (%2)", $self->author->author(), + $self->author->email() ), + Package => $self->package, + Description => $self->description || loc('None given'), + 'Version on CPAN' => $self->version, + }; + + ### check if we have the module installed + ### if so, add version have and version on cpan + $res->{'Version Installed'} = $self->installed_version + if $self->installed_version; + $res->{'Installed File'} = $self->installed_file if $self->installed_file; + + my $i = 0; + for my $item( split '', $self->dslip ) { + $res->{ $cb->_dslip_defs->[$i]->[0] } = + $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown'); + $i++; + } + + return $res; +} + +=head2 @list = $self->contains() + +Returns a list of module objects that represent the modules also +present in the package of this module. + +For example, for C this might return: + + Archive::Tar + Archive::Tar::Constant + Archive::Tar::File + +=cut + +sub contains { + my $self = shift; + my $cb = $self->parent; + my $pkg = $self->package; + + my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] ); + + return @mods; +} + +=pod + +=head2 @list_of_hrefs = $self->fetch_report() + +This function queries the CPAN testers database at +I for test results of specified module +objects, module names or distributions. + +Look at L for details on +the options you can pass and the return value to expect. + +=cut + +sub fetch_report { + my $self = shift; + my $cb = $self->parent; + + return $cb->_query_report( @_, module => $self ); +} + +=pod + +=head2 $bool = $self->uninstall([type => [all|man|prog]) + +This function uninstalls the specified module object. + +You can install 2 types of files, either C pages or Cram +files. Alternately you can specify C to uninstall both (which +is the default). + +Returns true on success and false on failure. + +Do note that this does an uninstall via the so-called C<.packlist>, +so if you used a module installer like say, C or C, you +should not use this, but use your package manager instead. + +=cut + +sub uninstall { + my $self = shift; + my $conf = $self->parent->configure_object(); + my %hash = @_; + + my ($type,$verbose); + my $tmpl = { + type => { default => 'all', allow => [qw|man prog all|], + store => \$type }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + force => { default => $conf->get_conf('force') }, + }; + + ### XXX add a warning here if your default install dist isn't + ### makefile or build -- that means you are using a package manager + ### and this will not do what you think! + + my $args = check( $tmpl, \%hash ) or return; + + if( $conf->get_conf('dist_type') and ( + ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or + ($conf->get_conf('dist_type') ne INSTALLER_MM)) + ) { + msg(loc("You have a default installer type set (%1) ". + "-- you should probably use that package manager to " . + "uninstall modules", $conf->get_conf('dist_type')), $verbose); + } + + ### check if we even have the module installed -- no point in continuing + ### otherwise + unless( $self->installed_version ) { + error( loc( "Module '%1' is not installed, so cannot uninstall", + $self->module ) ); + return; + } + + ### nothing to uninstall ### + my $files = $self->files( type => $type ) or return; + my $dirs = $self->directory_tree( type => $type ) or return; + my $sudo = $conf->get_program('sudo'); + + ### just in case there's no file; M::B doensn't provide .packlists yet ### + my $pack = $self->packlist; + $pack = $pack->[0]->packlist_file() if $pack; + + ### first remove the files, then the dirs if they are empty ### + my $flag = 0; + for my $file( @$files, $pack ) { + next unless defined $file && -f $file; + + msg(loc("Unlinking '%1'", $file), $verbose); + + my @cmd = ($^X, "-eunlink+q[$file]"); + unshift @cmd, $sudo if $sudo; + + my $buffer; + unless ( run( command => \@cmd, + verbose => $verbose, + buffer => \$buffer ) + ) { + error(loc("Failed to unlink '%1': '%2'",$file, $buffer)); + $flag++; + } + } + + for my $dir ( sort @$dirs ) { + local *DIR; + open DIR, $dir or next; + my @count = readdir(DIR); + close DIR; + + next unless @count == 2; # . and .. + + msg(loc("Removing '%1'", $dir), $verbose); + + ### this fails on my win2k machines.. it indeed leaves the + ### dir, but it's not a critical error, since the files have + ### been removed. --kane + #unless( rmdir $dir ) { + # error( loc( "Could not remove '%1': %2", $dir, $! ) ) + # unless $^O eq 'MSWin32'; + #} + + my @cmd = ($^X, "-ermdir+q[$dir]"); + unshift @cmd, $sudo if $sudo; + + my $buffer; + unless ( run( command => \@cmd, + verbose => $verbose, + buffer => \$buffer ) + ) { + error(loc("Failed to rmdir '%1': %2",$dir,$buffer)); + $flag++; + } + } + + $self->status->uninstall(!$flag); + $self->status->installed( $flag ? 1 : undef); + + return !$flag; +} + +=pod + +=head2 @modobj = $self->distributions() + +Returns a list of module objects representing all releases for this +module on success, false on failure. + +=cut + +sub distributions { + my $self = shift; + my %hash = @_; + + my @list = $self->author->distributions( %hash, module => $self ) or return; + + ### it's another release then by the same author ### + return grep { $_->package_name eq $self->package_name } @list; +} + +=pod + +=head2 @list = $self->files () + +Returns a list of files used by this module, if it is installed. + +=cut + +sub files { + return shift->_extutils_installed( @_, method => 'files' ); +} + +=pod + +=head2 @list = $self->directory_tree () + +Returns a list of directories used by this module. + +=cut + +sub directory_tree { + return shift->_extutils_installed( @_, method => 'directory_tree' ); +} + +=pod + +=head2 @list = $self->packlist () + +Returns the C object for this module. + +=cut + +sub packlist { + return shift->_extutils_installed( @_, method => 'packlist' ); +} + +=pod + +=head2 @list = $self->validate () + +Returns a list of files that are missing for this modules, but +are present in the .packlist file. + +=cut + +sub validate { + return shift->_extutils_installed( method => 'validate' ); +} + +### generic method to call an ExtUtils::Installed method ### +sub _extutils_installed { + my $self = shift; + my $conf = $self->parent->configure_object(); + my %hash = @_; + + my ($verbose,$type,$method); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose, }, + type => { default => 'all', + allow => [qw|prog man all|], + store => \$type, }, + method => { required => 1, + store => \$method, + allow => [qw|files directory_tree packlist + validate|], + }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we + ### find we're being used by them + { my $err = ON_OLD_CYGWIN; + if($err) { error($err); return }; + } + + return unless can_load( + modules => { 'ExtUtils::Installed' => '0.0' }, + verbose => $verbose, + ); + + my $inst; + unless( $inst = ExtUtils::Installed->new() ) { + error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) ); + + ### in case it's being used directly... ### + return; + } + + + { ### EU::Installed can die =/ + my @files; + eval { @files = $inst->$method( $self->module, $type ) }; + + if( $@ ) { + chomp $@; + error( loc("Could not get '%1' for '%2': %3", + $method, $self->module, $@ ) ); + return; + } + + return wantarray ? @files : \@files; + } +} + +=head2 $bool = $self->add_to_includepath; + +Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows +you to add the module from it's build dir to your path. + +You can reset C<@INC> and C<$PERL5LIB> to it's original state when you +started the program, by calling: + + $self->parent->flush('lib'); + +=cut + +sub add_to_includepath { + my $self = shift; + my $cb = $self->parent; + + if( my $dir = $self->status->extract ) { + + $cb->_add_to_includepath( + directories => [ + File::Spec->catdir(BLIB->($dir), LIB), + File::Spec->catdir(BLIB->($dir), ARCH), + BLIB->($dir), + ] + ) or return; + + } else { + error(loc( "No extract dir registered for '%1' -- can not add ". + "add builddir to search path!", $self->module )); + return; + } + + return 1; + +} + +=pod + +=head2 $path = $self->best_path_to_module_build(); + +B + +If a newer version of Module::Build is found in your path, it will +return this C path. If the newest version of C +is found in your regular C<@INC>, the method will return false. This +indicates you do not need to add a special directory to your C<@INC>. + +Note that this is only relevant if you're building your own +C plugin -- the built-in dist types already have +this taken care of. + +=cut + +### make sure we're always running 'perl Build.PL' and friends +### against the highest version of module::build available +sub best_path_to_module_build { + my $self = shift; + + ### Since M::B will actually shell out and run the Build.PL, we must + ### make sure it refinds the proper version of M::B in the path. + ### that may be either in our cp::inc or in site_perl, or even a + ### new M::B being installed. + ### don't add anything else here, as that might screw up prereq checks + + ### XXX this might be needed for Dist::MM too, if a makefile.pl is + ### masquerading as a Build.PL + + ### did we find the most recent module::build in our installer path? + + ### XXX can't do changes to @INC, they're being ignored by + ### new_from_context when writing a Build script. see ticket: + ### #8826 Module::Build ignores changes to @INC when writing Build + ### from new_from_context + ### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04) + ### and upped the version to 0.26061 of the bundled version, and things + ### work again + + ### this functionality is now obsolete -- prereqs should be installed + ### and we no longer use the CPANPLUS::inc magic.. so comment this out. +# require Module::Build; +# if( CPANPLUS::inc->path_to('Module::Build') and ( +# CPANPLUS::inc->path_to('Module::Build') eq +# CPANPLUS::inc->installer_path ) +# ) { +# +# ### if the module being installed is *not* Module::Build +# ### itself -- as that would undoubtedly be newer -- add +# ### the path to the installers to @INC +# ### if it IS module::build itself, add 'lib' to its path, +# ### as the Build.PL would do as well, but the API doesn't. +# ### this makes self updates possible +# return $self->module eq 'Module::Build' +# ? 'lib' +# : CPANPLUS::inc->installer_path; +# } + + ### otherwise, the path was found through a 'normal' way of + ### scanning @INC. + return; +} + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +1; + +__END__ + +todo: +reports(); diff --git a/lib/CPANPLUS/Module/Author.pm b/lib/CPANPLUS/Module/Author.pm new file mode 100644 index 0000000..95de09c --- /dev/null +++ b/lib/CPANPLUS/Module/Author.pm @@ -0,0 +1,213 @@ +package CPANPLUS::Module::Author; + +use strict; + +use CPANPLUS::Error; +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Module::Author + +=head1 SYNOPSIS + + my $author = CPANPLUS::Module::Author->new( + author => 'Jack Ashton', + cpanid => 'JACKASH', + _id => INTERNALS_OBJECT_ID, + ); + + $author->cpanid; + $author->author; + $author->email; + + @dists = $author->distributions; + @mods = $author->modules; + + @accessors = CPANPLUS::Module::Author->accessors; + +=head1 DESCRIPTION + +C creates objects from the information in the +source files. These can then be used to query on. + +These objects should only be created internally. For C objects, +there's the C class. + +=head1 ACCESSORS + +An objects of this class has the following accessors: + +=over 4 + +=item author + +Name of the author. + +=item cpanid + +The CPAN id of the author. + +=item email + +The email address of the author, which defaults to '' if not provided. + +=item parent + +The C that spawned this module object. + +=back + +=cut + +my $tmpl = { + author => { required => 1 }, # full name of the author + cpanid => { required => 1 }, # cpan id + email => { default => '' }, # email address of the author + _id => { required => 1 }, # id of the Internals object that spawned us +}; + +### autogenerate accessors ### +for my $key ( keys %$tmpl ) { + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + my $self = shift; + $self->{$key} = $_[0] if @_; + return $self->{$key}; + } +} + +sub parent { + my $self = shift; + my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id ); + + return $obj; +} + +=pod + +=head1 METHODS + +=head2 $auth = CPANPLUS::Module::Author->new( author => AUTHOR_NAME, cpanid => CPAN_ID, _id => INTERNALS_ID [, email => AUTHOR_EMAIL] ) + +This method returns a C object, based on the given +parameters. + +Returns false on failure. + +=cut + +sub new { + my $class = shift; + my %hash = @_; + + ### don't check the template for sanity + ### -- we know it's good and saves a lot of performance + local $Params::Check::SANITY_CHECK_TEMPLATE = 0; + + my $object = check( $tmpl, \%hash ) or return; + + return bless $object, $class; +} + +=pod + +=head2 @mod_objs = $auth->modules() + +Return a list of module objects this author has released. + +=cut + +sub modules { + my $self = shift; + my $cb = $self->parent; + + my $aref = $cb->_search_module_tree( + type => 'author', + allow => [$self], + ); + return @$aref if $aref; + return; +} + +=pod + +=head2 @dists = $auth->distributions() + +Returns a list of module objects representing all the distributions +this author has released. + +=cut + +sub distributions { + my $self = shift; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + local $Params::Check::NO_DUPLICATES = 1; + + my $mod; + my $tmpl = { + module => { default => '', store => \$mod }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### if we didn't get a module object passed, we'll find one ourselves ### + unless( $mod ) { + my @list = $self->modules; + if( @list ) { + $mod = $list[0]; + } else { + error( loc( "This author has released no modules" ) ); + return; + } + } + + my $file = $mod->checksums( %hash ); + my $href = $mod->_parse_checksums_file( file => $file ) or return; + + my @rv; + for my $dist ( keys %$href ) { + my $clone = $mod->clone; + + $clone->package( $dist ); + $clone->module( $clone->package_name ); + $clone->version( $clone->package_version ); + $clone->mtime( $href->{$dist}->{'mtime'} ); # release date + + ### .meta files are now also in the checksums file, + ### which means we have to filter out things that dont + ### match our regex + push @rv, $clone if $clone->package_extension; + } + + return @rv; +} + + +=pod + +=head1 CLASS METHODS + +=head2 accessors () + +Returns a list of all accessor methods to the object + +=cut + +sub accessors { return keys %$tmpl }; + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Module/Author/Fake.pm b/lib/CPANPLUS/Module/Author/Fake.pm new file mode 100644 index 0000000..115c29e --- /dev/null +++ b/lib/CPANPLUS/Module/Author/Fake.pm @@ -0,0 +1,80 @@ +package CPANPLUS::Module::Author::Fake; + + +use CPANPLUS::Module::Author; +use CPANPLUS::Internals; +use CPANPLUS::Error; + +use strict; +use vars qw[@ISA]; +use Params::Check qw[check]; + +@ISA = qw[CPANPLUS::Module::Author]; + +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Module::Author::Fake + +=head1 SYNOPSIS + + my $auth = CPANPLUS::Module::Author::Fake->new( + name => 'Foo Bar', + email => 'luser@foo.com', + cpanid => 'FOO', + _id => $cpan->id, + ); + +=head1 DESCRIPTION + +A class for creating fake author objects, for shortcut use internally +by CPANPLUS. + +Inherits from C. + +=head1 METHODS + +=head2 new( _id => DIGIT ) + +Creates a dummy author object. It can take the same options as +C<< CPANPLUS::Module::Author->new >>, but will fill in default ones +if none are provided. Only the _id key is required. + +=cut + +sub new { + my $class = shift; + my %hash = @_; + + my $tmpl = { + author => { default => 'CPANPLUS Internals' }, + email => { default => 'cpanplus-info@lists.sf.net' }, + cpanid => { default => 'CPANPLUS' }, + _id => { default => CPANPLUS::Internals->_last_id }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $obj = CPANPLUS::Module::Author->new( %$args ) or return; + + unless( $obj->_id ) { + error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id')); + return; + } + + ### rebless object ### + return bless $obj, $class; +} + +1; + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Module/Checksums.pm b/lib/CPANPLUS/Module/Checksums.pm new file mode 100644 index 0000000..92a2cc2 --- /dev/null +++ b/lib/CPANPLUS/Module/Checksums.pm @@ -0,0 +1,251 @@ +package CPANPLUS::Module::Checksums; + +use strict; +use vars qw[@ISA]; + + +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +use FileHandle; + +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; + +$Params::Check::VERBOSE = 1; + +@ISA = qw[ CPANPLUS::Module::Signature ]; + +=head1 NAME + +CPANPLUS::Module::Checksums + +=head1 SYNOPSIS + + $file = $modobj->checksums; + $bool = $mobobj->_validate_checksum; + +=head1 DESCRIPTION + +This is a class that provides functions for checking the checksum +of a distribution. Should not be loaded directly, but used via the +interface provided via C. + +=head1 METHODS + +=head2 $mod->checksums + +Fetches the checksums file for this module object. +For the options it can take, see C. + +Returns the location of the checksums file on success and false +on error. + +The location of the checksums file is also stored as + + $mod->status->checksums + +=cut + +sub checksums { + my $mod = shift or return; + + my $file = $mod->_get_checksums_file( @_ ); + + return $mod->status->checksums( $file ) if $file; + + return; +} + +### checks if the package checksum matches the one +### from the checksums file +sub _validate_checksum { + my $self = shift; #must be isa CPANPLUS::Module + my $conf = $self->parent->configure_object; + my %hash = @_; + + my $verbose; + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return; + + ### if we can't check it, we must assume it's ok ### + return $self->status->checksum_ok(1) + unless can_load( modules => { 'Digest::MD5' => '0.0' } ); + #class CPANPLUS::Module::Status is runtime-generated + + my $file = $self->_get_checksums_file( verbose => $verbose ) or ( + error(loc(q[Could not fetch '%1' file], CHECKSUMS)), return ); + + $self->_check_signature_for_checksum_file( file => $file ) or ( + error(loc(q[Could not verify '%1' file], CHECKSUMS)), return ); + #for whole CHECKSUMS file + + my $href = $self->_parse_checksums_file( file => $file ) or ( + error(loc(q[Could not parse '%1' file], CHECKSUMS)), return ); + + my $size = $href->{ $self->package }->{'size'}; + + ### the checksums file tells us the size of the archive + ### but the downloaded file is of different size + if( defined $size ) { + if( not (-s $self->status->fetch == $size) ) { + error(loc( "Archive size does not match for '%1': " . + "size is '%2' but should be '%3'", + $self->package, -s $self->status->fetch, $size)); + return $self->status->checksum_ok(0); + } + } else { + msg(loc("Archive size is not known for '%1'",$self->package),$verbose); + } + + my $md5 = $href->{ $self->package }->{'md5'}; + + unless( defined $md5 ) { + msg(loc("No 'md5' checksum known for '%1'",$self->package),$verbose); + + return $self->status->checksum_ok(1); + } + + $self->status->checksum_value($md5); + + + my $fh = FileHandle->new( $self->status->fetch ) or return; + binmode $fh; + + my $ctx = Digest::MD5->new; + $ctx->addfile( $fh ); + + my $flag = $ctx->hexdigest eq $md5; + $flag + ? msg(loc("Checksum matches for '%1'", $self->package),$verbose) + : error(loc("Checksum does not match for '%1': " . + "MD5 is '%2' but should be '%3'", + $self->package, $ctx->hexdigest, $md5),$verbose); + + + return $self->status->checksum_ok(1) if $flag; + return $self->status->checksum_ok(0); +} + + +### fetches the module objects checksum file ### +sub _get_checksums_file { + my $self = shift; + my %hash = @_; + + my $clone = $self->clone; + $clone->package( CHECKSUMS ); + + my $file = $clone->fetch( %hash, force => 1 ) or return; + + return $file; +} + +sub _parse_checksums_file { + my $self = shift; + my %hash = @_; + + my $file; + my $tmpl = { + file => { required => 1, allow => FILE_READABLE, store => \$file }, + }; + my $args = check( $tmpl, \%hash ); + + my $fh = OPEN_FILE->( $file ) or return; + + ### loop over the header, there might be a pgp signature ### + my $signed; + while (<$fh>) { + last if /^\$cksum = \{\s*$/; # skip till this line + my $header = PGP_HEADER; # but be tolerant of whitespace + $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks + } + + ### read the filehandle, parse it rather than eval it, even though it + ### *should* be valid perl code + my $dist; + my $cksum = {}; + while (<$fh>) { + + if (/^\s*'([^']+)' => \{\s*$/) { + $dist = $1; + + } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) { + $cksum->{$dist}{$1} = $2; + + } elsif (/^\s*}[,;]?\s*$/) { + undef $dist; + + } elsif (/^__END__\s*$/) { + last; + + } else { + error( loc("Malformed %1 line: %2", CHECKSUMS, $_) ); + } + } + + return $cksum; +} + +sub _check_signature_for_checksum_file { + my $self = shift; + + my $conf = $self->parent->configure_object; + my %hash = @_; + + ### you don't want to check signatures, + ### so let's just return true; + return 1 unless $conf->get_conf('signature'); + + my($force,$file,$verbose); + my $tmpl = { + file => { required => 1, allow => FILE_READABLE, store => \$file }, + force => { default => $conf->get_conf('force'), store => \$force }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + my $fh = OPEN_FILE->($file) or return; + + my $signed; + while (<$fh>) { + my $header = PGP_HEADER; + $signed = 1 if /^$header$/; + } + + if ( !$signed ) { + msg(loc("No signature found in %1 file '%2'", + CHECKSUMS, $file), $verbose); + + return 1 unless $force; + + error( loc( "%1 file '%2' is not signed -- aborting", + CHECKSUMS, $file ) ); + return; + + } + + if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) { + # local $Module::Signature::SIGNATURE = $file; + # ... check signatures ... + } + + return 1; +} + + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +1; diff --git a/lib/CPANPLUS/Module/Fake.pm b/lib/CPANPLUS/Module/Fake.pm new file mode 100644 index 0000000..84d0233 --- /dev/null +++ b/lib/CPANPLUS/Module/Fake.pm @@ -0,0 +1,86 @@ +package CPANPLUS::Module::Fake; + + +use CPANPLUS::Error; +use CPANPLUS::Module; +use CPANPLUS::Module::Author::Fake; +use CPANPLUS::Internals; + +use strict; +use vars qw[@ISA]; +use Params::Check qw[check]; + +@ISA = qw[CPANPLUS::Module]; +$Params::Check::VERBOSE = 1; + +=pod + +=head1 NAME + +CPANPLUS::Module::Fake + +=head1 SYNOPSIS + + my $obj = CPANPLUS::Module::Fake->new( + module => 'Foo', + path => 'ftp/path/to/foo', + author => CPANPLUS::Module::Author::Fake->new, + package => 'fake-1.1.tgz', + _id => $cpan->_id, + ); + +=head1 DESCRIPTION + +A class for creating fake module objects, for shortcut use internally +by CPANPLUS. + +Inherits from C. + +=head1 METHODS + +=head2 new( module => $mod, path => $path, package => $pkg, [_id => DIGIT] ) + +Creates a dummy module object from the above parameters. It can +take more options (same as C<< CPANPLUS::Module->new >> but the above +are required. + +=cut + +sub new { + my $class = shift; + my %hash = @_; + + local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + module => { required => 1 }, + path => { required => 1 }, + package => { required => 1 }, + _id => { default => CPANPLUS::Internals->_last_id }, + author => { default => '' }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + $args->{author} ||= CPANPLUS::Module::Author::Fake->new( + _id => $args->{_id} ); + + my $obj = CPANPLUS::Module->new( %$args ) or return; + + unless( $obj->_id ) { + error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id')); + return; + } + + ### rebless object ### + return bless $obj, $class; +} + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Module/Signature.pm b/lib/CPANPLUS/Module/Signature.pm new file mode 100644 index 0000000..cec6f29 --- /dev/null +++ b/lib/CPANPLUS/Module/Signature.pm @@ -0,0 +1,65 @@ +package CPANPLUS::Module::Signature; + +use strict; + + +use Cwd; +use CPANPLUS::Error; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; + + +### detached sig, not actually used afaik --kane ### +#sub get_signature { +# my $self = shift; +# +# my $clone = $self->clone; +# $clone->package( $self->package . '.sig' ); +# +# return $clone->fetch; +#} + +sub check_signature { + my $self = shift; + my $cb = $self->parent; + my $conf = $cb->configure_object; + my %hash = @_; + + my $verbose; + my $tmpl = { + verbose => {default => $conf->get_conf('verbose'), store => \$verbose}, + }; + + check( $tmpl, \%hash ) or return; + + my $dir = $self->status->extract or ( + error( loc( "Do not know what dir '%1' was extracted to; ". + "Cannot check signature", $self->module ) ), + return ); + + my $cwd = cwd(); + unless( $cb->_chdir( dir => $dir ) ) { + error(loc( "Could not chdir to '%1', cannot verify distribution '%2'", + $dir, $self->module )); + return; + } + + + ### check prerequisites + my $flag; + my $use_list = { 'Module::Signature' => '0.06' }; + if( can_load( modules => $use_list, verbose => 1 ) ) { + my $rv = Module::Signature::verify(); + + unless ($rv eq Module::Signature::SIGNATURE_OK() or + $rv eq Module::Signature::SIGNATURE_MISSING() + ) { + $flag++; # whoops, bad sig + } + } + + $cb->_chdir( dir => $cwd ); + return $flag ? 0 : 1; +} + +1; diff --git a/lib/CPANPLUS/Selfupdate.pm b/lib/CPANPLUS/Selfupdate.pm new file mode 100644 index 0000000..2271dd4 --- /dev/null +++ b/lib/CPANPLUS/Selfupdate.pm @@ -0,0 +1,447 @@ +package CPANPLUS::Selfupdate; + +use strict; +use Params::Check qw[check]; +use IPC::Cmd qw[can_run]; +use CPANPLUS::Error qw[error msg]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use CPANPLUS::Internals::Constants; + +$Params::Check::VERBOSE = 1; + +=head1 NAME + +CPANPLUS::Selfupdate + +=head1 SYNOPSIS + + $su = $cb->selfupdate_object; + + @feats = $su->list_features; + @feats = $su->list_enabled_features; + + @mods = map { $su->modules_for_feature( $_ ) } @feats; + @mods = $su->list_core_dependencies; + @mods = $su->list_core_modules; + + for ( @mods ) { + print $_->name " should be version " . $_->version_required; + print "Installed version is not uptodate!" + unless $_->is_installed_version_sufficient; + } + + $ok = $su->selfupdate( update => 'all', latest => 0 ); + +=cut + +### a config has describing our deps etc +{ + + my $Modules = { + dependencies => { + 'File::Fetch' => '0.08', # win32 ftp support + 'File::Spec' => '0.82', + 'IPC::Cmd' => '0.36', # 5.6.2 compat: 2-arg open + 'Locale::Maketext::Simple' => '0.01', + 'Log::Message' => '0.01', + 'Module::Load' => '0.10', + 'Module::Load::Conditional' => '0.16', # Better parsing: #23995 + 'version' => '0.70', # needed for M::L::C + # addresses #24630 and + # #24675 + 'Params::Check' => '0.22', + 'Package::Constants' => '0.01', + 'Term::UI' => '0.05', + 'Test::Harness' => '2.62', # due to bug #19505 + # only 2.58 and 2.60 are bad + 'Test::More' => '0.47', # to run our tests + 'Archive::Extract' => '0.16', # ./Dir bug fix + 'Archive::Tar' => '1.23', + 'IO::Zlib' => '1.04', # needed for Archive::Tar + 'Object::Accessor' => '0.32', # overloaded stringification + 'Module::CoreList' => '2.09', + 'Module::Pluggable' => '2.4', + 'Module::Loaded' => '0.01', + }, + + features => { + # config_key_name => [ + # sub { } to list module key/value pairs + # sub { } to check if feature is enabled + # ] + prefer_makefile => [ + sub { + my $cb = shift; + $cb->configure_object->get_conf('prefer_makefile') + ? { } + : { 'CPANPLUS::Dist::Build' => '0.04' }; + }, + sub { return 1 }, # always enabled + ], + cpantest => [ + { + LWP => '0.0', + 'LWP::UserAgent' => '0.0', + 'HTTP::Request' => '0.0', + URI => '0.0', + YAML => '0.0', + 'Test::Reporter' => 1.27, + }, + sub { + my $cb = shift; + return $cb->configure_object->get_conf('cpantest'); + }, + ], + dist_type => [ + sub { + my $cb = shift; + my $dist = $cb->configure_object->get_conf('dist_type'); + return { $dist => '0.0' } if $dist; + return; + }, + sub { + my $cb = shift; + return $cb->configure_object->get_conf('dist_type'); + }, + ], + + md5 => [ + { + 'Digest::MD5' => '0.0', + }, + sub { + my $cb = shift; + return $cb->configure_object->get_conf('md5'); + }, + ], + shell => [ + sub { + my $cb = shift; + my $dist = $cb->configure_object->get_conf('shell'); + return { $dist => '0.0' } if $dist; + return; + }, + sub { return 1 }, + ], + signature => [ + sub { + my $cb = shift; + return if can_run('gpg') and + $cb->configure_object->get_conf('prefer_bin'); + return { 'Crypt::OpenPGP' => '0.0' }; + }, + sub { + my $cb = shift; + return $cb->configure_object->get_conf('signature'); + }, + ], + storable => [ + { 'Storable' => '0.0' }, + sub { + my $cb = shift; + return $cb->configure_object->get_conf('storable'); + }, + ], + }, + core => { + 'CPANPLUS' => '0.0', + }, + }; + + sub _get_config { return $Modules } +} + +=head1 METHODS + +=head2 $self = CPANPLUS::Selfupdate->new( $backend_object ); + +Sets up a new selfupdate object. Called automatically when +a new backend object is created. + +=cut + +sub new { + my $class = shift; + my $cb = shift or return; + return bless sub { $cb }, $class; +} + + + +=head2 $bool = $self->selfupdate( update => "core|dependencies|enabled_features|features|all", latest => BOOL ) + +Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself), +the core dependencies, all features you have currently turned on, or +all features available, or everything. + +The C option determines whether it should update to the latest +version on CPAN, or if the minimal required version for CPANPLUS is +good enough. + +Returns true on success, false on error. + +=cut + +sub selfupdate { + my $self = shift; + my $cb = $self->(); + my $conf = $cb->configure_object; + my %hash = @_; + + ### cache to find the relevant modules + my $cache = { + core => sub { $self->list_core_modules }, + dependencies => sub { $self->list_core_dependencies }, + enabled_features => sub { map { $self->modules_for_feature( $_ ) } + $self->list_enabled_features + }, + features => sub { map { $self->modules_for_feature( $_ ) } + $self->list_features + }, + ### make sure to do 'core' first, in case + ### we are out of date ourselves + all => [ qw|core dependencies enabled_features| ], + }; + + my($type, $latest, $force); + my $tmpl = { + update => { required => 1, store => \$type, + allow => [ keys %$cache ], }, + latest => { default => 0, store => \$latest, allow => BOOLEANS }, + force => { default => $conf->get_conf('force'), store => \$force }, + }; + + check( $tmpl, \%hash ) or return; + + my $ref = $cache->{$type}; + my @mods = UNIVERSAL::isa( $ref, 'ARRAY' ) + ? map { $cache->{$_}->() } @$ref + : $ref->(); + + ### do we need the latest versions? + @mods = $latest + ? @mods + : grep { $_->is_installed_version_sufficient } @mods; + + my $flag; + for my $mod ( @mods ) { + unless( $mod->install( force => $force ) ) { + $flag++; + error(loc("Failed to update module '%1'", $mod->name)); + } + } + + return if $flag; + return 1; +} + +=head2 @features = $self->list_features + +Returns a list of features that are supported by CPANPLUS. + +=cut + +sub list_features { + my $self = shift; + return keys %{ $self->_get_config->{'features'} }; +} + +=head2 @features = $self->list_enabled_features + +Returns a list of features that are enabled in your current +CPANPLUS installation. + +=cut + +sub list_enabled_features { + my $self = shift; + my $cb = $self->(); + + my @enabled; + for my $feat ( $self->list_features ) { + my $ref = $self->_get_config->{'features'}->{$feat}->[1]; + push @enabled, $feat if $ref->($cb); + } + + return @enabled; +} + +=head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] ) + +Returns a list of C objects which +represent the modules required to support this feature. + +For a list of features, call the C method. + +If the C argument is provided, no module objects are +returned, but a hashref where the keys are names of the modules, +and values are their minimum versions. + +=cut + +sub modules_for_feature { + my $self = shift; + my $feature = shift or return; + my $as_hash = shift || 0; + my $cb = $self->(); + + unless( exists $self->_get_config->{'features'}->{$feature} ) { + error(loc("Unknown feature '%1'", $feature)); + return; + } + + my $ref = $self->_get_config->{'features'}->{$feature}->[0]; + + ### it's either a list of modules/versions or a subroutine that + ### returns a list of modules/versions + my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb ); + + return unless $href; # nothing needed for the feature? + + return $href if $as_hash; + return $self->_hashref_to_module( $href ); +} + + +=head2 @mods = $self->list_core_dependencies( [AS_HASH] ) + +Returns a list of C objects which +represent the modules that comprise the core dependencies of CPANPLUS. + +If the C argument is provided, no module objects are +returned, but a hashref where the keys are names of the modules, +and values are their minimum versions. + +=cut + +sub list_core_dependencies { + my $self = shift; + my $as_hash = shift || 0; + my $cb = $self->(); + my $href = $self->_get_config->{'dependencies'}; + + return $href if $as_hash; + return $self->_hashref_to_module( $href ); +} + +=head2 @mods = $self->list_core_modules( [AS_HASH] ) + +Returns a list of C objects which +represent the modules that comprise the core of CPANPLUS. + +If the C argument is provided, no module objects are +returned, but a hashref where the keys are names of the modules, +and values are their minimum versions. + +=cut + +sub list_core_modules { + my $self = shift; + my $as_hash = shift || 0; + my $cb = $self->(); + my $href = $self->_get_config->{'core'}; + + return $href if $as_hash; + return $self->_hashref_to_module( $href ); +} + +sub _hashref_to_module { + my $self = shift; + my $cb = $self->(); + my $href = shift or return; + + return map { + CPANPLUS::Selfupdate::Module->new( + $cb->module_tree($_) => $href->{$_} + ) + } keys %$href; +} + + +=head1 CPANPLUS::Selfupdate::Module + +C extends C objects +by providing accessors to aid in selfupdating CPANPLUS. + +These objects are returned by all methods of C +that return module objects. + +=cut + +{ package CPANPLUS::Selfupdate::Module; + use base 'CPANPLUS::Module'; + + ### stores module name -> cpanplus required version + ### XXX only can deal with 1 pair! + my %Cache = (); + my $Acc = 'version_required'; + + sub new { + my $class = shift; + my $mod = shift or return; + my $ver = shift; return unless defined $ver; + + my $obj = $mod->clone; # clone the module object + bless $obj, $class; # rebless it to our class + + $obj->$Acc( $ver ); + + return $obj; + } + +=head2 $version = $mod->version_required + +Returns the version of this module required for CPANPLUS. + +=cut + + sub version_required { + my $self = shift; + $Cache{ $self->name } = shift() if @_; + return $Cache{ $self->name }; + } + +=head2 $bool = $mod->is_installed_version_sufficient + +Returns true if the installed version of this module is sufficient +for CPANPLUS, or false if it is not. + +=cut + + + sub is_installed_version_sufficient { + my $self = shift; + return $self->is_uptodate( version => $self->$Acc ); + } + +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Shell.pm b/lib/CPANPLUS/Shell.pm new file mode 100644 index 0000000..4128e03 --- /dev/null +++ b/lib/CPANPLUS/Shell.pm @@ -0,0 +1,314 @@ +package CPANPLUS::Shell; + +use strict; + +use CPANPLUS::Error; +use CPANPLUS::Configure; + + +use Module::Load qw[load]; +use Params::Check qw[check]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + +use vars qw[@ISA $SHELL $DEFAULT]; + +$DEFAULT = 'CPANPLUS::Shell::Default'; + +=pod + +=head1 NAME + +CPANPLUS::Shell + +=head1 SYNOPSIS + + use CPANPLUS::Shell; # load the shell indicated by your + # config -- defaults to + # CPANPLUS::Shell::Default + + use CPANPLUS::Shell qw[Classic] # load CPANPLUS::Shell::Classic; + + my $ui = CPANPLUS::Shell->new(); + my $name = $ui->which; # Find out what shell you loaded + + $ui->shell; # run the ui shell + + +=head1 DESCRIPTION + +This module is the generic loading (and base class) for all C +shells. Through this module you can load any installed C +shell. + +Just about all the functionality is provided by the shell that you have +loaded, and not by this class (which merely functions as a generic +loading class), so please consult the documentation of your shell of +choice. + +=cut + + +sub import { + my $class = shift; + my $option = shift; + ### XXX this should offer to reconfigure CPANPLUS, somehow. --rs + my $conf = CPANPLUS::Configure->new() + or die loc("No configuration available -- aborting") . $/; + + ### find out what shell we're supposed to load ### + $SHELL = $option + ? $class . '::' . $option + : $conf->get_conf('shell') || $DEFAULT; + + ### load the shell, fall back to the default if required + ### and die if even that doesn't work + EVAL: { + eval { load $SHELL }; + + if( $@ ) { + my $err = $@; + + die loc("Your default shell '%1' is not available: %2", + $DEFAULT, $err) . + loc("Check your installation!") . "\n" + if $SHELL eq $DEFAULT; + + warn loc("Failed to use '%1': %2", $SHELL, $err), + loc("Switching back to the default shell '%1'", $DEFAULT), + "\n"; + + $SHELL = $DEFAULT; + redo EVAL; + } + } + @ISA = ($SHELL); +} + +sub which { return $SHELL } + +1; + +########################################################################### +### abstracted out subroutines available to programmers of other shells ### +########################################################################### + +package CPANPLUS::Shell::_Base::ReadLine; + +use strict; +use vars qw($AUTOLOAD $TMPL); + +use FileHandle; +use CPANPLUS::Error; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +$Params::Check::VERBOSE = 1; + + +$TMPL = { + brand => { default => '', strict_type => 1 }, + prompt => { default => '> ', strict_type => 1 }, + pager => { default => '' }, + backend => { default => '' }, + term => { default => '' }, + format => { default => '' }, + dist_format => { default => '' }, + remote => { default => undef }, + noninteractive => { default => '' }, + cache => { default => [ ] }, + _old_sigpipe => { default => '', no_override => 1 }, + _old_outfh => { default => '', no_override => 1 }, + _signals => { default => { INT => { } }, no_override => 1 }, +}; + +### autogenerate accessors ### +for my $key ( keys %$TMPL ) { + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + my $self = shift; + $self->{$key} = $_[0] if @_; + return $self->{$key}; + } +} + +sub _init { + my $class = shift; + my %hash = @_; + + my $self = check( $TMPL, \%hash ) or return; + + bless $self, $class; + + ### signal handler ### + $SIG{INT} = $self->_signals->{INT}->{handler} = + sub { + unless ( $self->_signals->{INT}->{count}++ ) { + warn loc("Caught SIGINT"), "\n"; + } else { + warn loc("Got another SIGINT"), "\n"; die; + } + }; + ### end sig handler ### + + return $self; +} + +### display shell's banner, takes the Backend object as argument +sub _show_banner { + my $self = shift; + my $cpan = $self->backend; + my $term = $self->term; + + ### Tries to probe for our ReadLine support status + # a) under an interactive shell? + my $rl_avail = (!$term->isa('CPANPLUS::Shell::_Faked')) + # b) do we have a tty terminal? + ? (-t STDIN) + # c) should we enable the term? + ? (!$self->__is_bad_terminal($term)) + # d) external modules available? + ? ($term->ReadLine ne "Term::ReadLine::Stub") + # a+b+c+d => "Smart" terminal + ? loc("enabled") + # a+b+c => "Stub" terminal + : loc("available (try 'i Term::ReadLine::Perl')") + # a+b => "Bad" terminal + : loc("disabled") + # a => "Dumb" terminal + : loc("suppressed") + # none => "Faked" terminal + : loc("suppressed in batch mode"); + + $rl_avail = loc("ReadLine support %1.", $rl_avail); + $rl_avail = "\n*** $rl_avail" if (length($rl_avail) > 45); + + print loc("%1 -- CPAN exploration and module installation (v%2)", + $self->which, $self->which->VERSION()), "\n", + loc("*** Please report bugs to ."), "\n", + loc("*** Using CPANPLUS::Backend v%1. %2", + $cpan->VERSION, $rl_avail), "\n\n"; +} + +### checks whether the Term::ReadLine is broken and needs to fallback to Stub +sub __is_bad_terminal { + my $self = shift; + my $term = $self->term; + + return unless $^O eq 'MSWin32'; + + ### replace the term with the default (stub) one + return $self->term(Term::ReadLine::Stub->new( $self->brand ) ); +} + +### open a pager handle +sub _pager_open { + my $self = shift; + my $cpan = $self->backend; + my $cmd = $cpan->configure_object->get_program('pager') or return; + + $self->_old_sigpipe( $SIG{PIPE} ); + $SIG{PIPE} = 'IGNORE'; + + my $fh = new FileHandle; + unless ( $fh->open("| $cmd") ) { + error(loc("could not pipe to %1: %2\n", $cmd, $!) ); + return; + } + + $fh->autoflush(1); + + $self->pager( $fh ); + $self->_old_outfh( select $fh ); + + return $fh; +} + +### print to the current pager handle, or STDOUT if it's not opened +sub _pager_close { + my $self = shift; + my $pager = $self->pager or return; + + $pager->close if (ref($pager) and $pager->can('close')); + + $self->pager( undef ); + + select $self->_old_outfh; + $SIG{PIPE} = $self->_old_sigpipe; + + return 1; +} + + + +{ + my $win32_console; + + ### determines row count of current terminal; defaults to 25. + ### used by the pager functions + sub _term_rowcount { + my $self = shift; + my $cpan = $self->backend; + my %hash = @_; + + my $default; + my $tmpl = { + default => { default => 25, allow => qr/^\d$/, + store => \$default } + }; + + check( $tmpl, \%hash ) or return; + + if ( $^O eq 'MSWin32' ) { + if ( can_load( modules => { 'Win32::Console' => '0.0' } ) ) { + $win32_console ||= Win32::Console->new(); + my $rows = ($win32_console->Info)[-1]; + return $rows; + } + + } else { + local $Module::Load::Conditional::VERBOSE = 0; + if ( can_load(modules => {'Term::Size' => '0.0'}) ) { + my ($cols, $rows) = Term::Size::chars(); + return $rows; + } + } + return $default; + } +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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, L, L + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/lib/CPANPLUS/Shell/Classic.pm b/lib/CPANPLUS/Shell/Classic.pm new file mode 100644 index 0000000..176548c --- /dev/null +++ b/lib/CPANPLUS/Shell/Classic.pm @@ -0,0 +1,1236 @@ +################################################## +### CPANPLUS/Shell/Classic.pm ### +### Backwards compatible shell for CPAN++ ### +### Written 08-04-2002 by Jos Boumans ### +################################################## + +package CPANPLUS::Shell::Classic; + +use strict; + + +use CPANPLUS::Error; +use CPANPLUS::Backend; +use CPANPLUS::Configure::Setup; +use CPANPLUS::Internals::Constants; + +use Cwd; +use IPC::Cmd; +use Term::UI; +use Data::Dumper; +use Term::ReadLine; + +use Module::Load qw[load]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load]; + +$Params::Check::VERBOSE = 1; +$Params::Check::ALLOW_UNKNOWN = 1; + +BEGIN { + use vars qw[ $VERSION @ISA ]; + @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; + $VERSION = '0.0562'; +} + +load CPANPLUS::Shell; + + +### our command set ### +my $map = { + a => '_author', + b => '_bundle', + d => '_distribution', + 'm' => '_module', + i => '_find_all', + r => '_uptodate', + u => '_not_supported', + ls => '_ls', + get => '_fetch', + make => '_install', + test => '_install', + install => '_install', + clean => '_not_supported', + look => '_shell', + readme => '_readme', + h => '_help', + '?' => '_help', + o => '_set_conf', + reload => '_reload', + autobundle => '_autobundle', + '!' => '_bang', + #'q' => '_quit', # done it the loop itself +}; + +### the shell object, scoped to the file ### +my $Shell; +my $Brand = 'cpan'; +my $Prompt = $Brand . '> '; + +sub new { + my $class = shift; + + my $cb = new CPANPLUS::Backend; + my $self = $class->SUPER::_init( + brand => $Brand, + term => Term::ReadLine->new( $Brand ), + prompt => $Prompt, + backend => $cb, + format => "%5s %-50s %8s %-10s\n", + ); + ### make it available package wide ### + $Shell = $self; + + ### enable verbose, it's the cpan.pm way + $cb->configure_object->set_conf( verbose => 1 ); + + + ### register install callback ### + $cb->_register_callback( + name => 'install_prerequisite', + code => \&__ask_about_install, + ); + + ### register test report callback ### + $cb->_register_callback( + name => 'edit_test_report', + code => \&__ask_about_test_report, + ); + + return $self; +} + +sub shell { + my $self = shift; + my $term = $self->term; + + $self->_show_banner; + $self->_input_loop && print "\n"; + $self->_quit; +} + +sub _input_loop { + my $self = shift; + my $term = $self->term; + my $cb = $self->backend; + + my $normal_quit = 0; + while ( + defined (my $input = eval { $term->readline($self->prompt) } ) + or $self->_signals->{INT}{count} == 1 + ) { + ### re-initiate all signal handlers + while (my ($sig, $entry) = each %{$self->_signals} ) { + $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); + } + + last if $self->_dispatch_on_input( input => $input ); + + ### flush the lib cache ### + $cb->_flush( list => [qw|lib load|] ); + + } continue { + $self->_signals->{INT}{count}-- + if $self->_signals->{INT}{count}; # clear the sigint count + } + + return 1; +} + +sub _dispatch_on_input { + my $self = shift; + my $conf = $self->backend->configure_object(); + my $term = $self->term; + my %hash = @_; + + my $string; + my $tmpl = { + input => { required => 1, store => \$string } + }; + + check( $tmpl, \%hash ) or return; + + ### the original force setting; + my $force_store = $conf->get_conf( 'force' ); + + ### parse the input: the first part before the space + ### is the command, followed by arguments. + ### see the usage below + my $key; + PARSE_INPUT: { + $string =~ s|^\s*([\w\?\!]+)\s*||; + chomp $string; + $key = lc($1); + } + + ### you prefixed the input with 'force' + ### that means we set the force flag, and + ### reparse the input... + ### YAY goto block :) + if( $key eq 'force' ) { + $conf->set_conf( force => 1 ); + goto PARSE_INPUT; + } + + ### you want to quit + return 1 if $key =~ /^q/; + + my $method = $map->{$key}; + unless( $self->can( $method ) ) { + print "Unknown command '$key'. Type ? for help.\n"; + return; + } + + ### dispatch the method call + eval { $self->$method( + command => $key, + result => [ split /\s+/, $string ], + input => $string ); + }; + warn $@ if $@; + + return; +} + +### displays quit message +sub _quit { + + ### well, that's what CPAN.pm says... + print "Lockfile removed\n"; +} + +sub _not_supported { + my $self = shift; + my %hash = @_; + + my $cmd; + my $tmpl = { + command => { required => 1, store => \$cmd } + }; + + check( $tmpl, \%hash ) or return; + + print "Sorry, the command '$cmd' is not supported\n"; + + return; +} + +sub _fetch { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $input); + my $tmpl = { + result => { store => \$aref, default => [] }, + input => { default => 'all', store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + for my $mod (@$aref) { + my $obj; + + unless( $obj = $cb->module_tree($mod) ) { + print "Warning: Cannot get $input, don't know what it is\n"; + print "Try the command\n\n"; + print "\ti /$mod/\n\n"; + print "to find objects with matching identifiers.\n"; + + next; + } + + $obj->fetch && $obj->extract; + } + + return $aref; +} + +sub _install { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $mapping = { + make => { target => TARGET_CREATE, skiptest => 1 }, + test => { target => TARGET_CREATE }, + install => { target => TARGET_INSTALL }, + }; + + my($aref,$cmd); + my $tmpl = { + result => { store => \$aref, default => [] }, + command => { required => 1, store => \$cmd, allow => [keys %$mapping] }, + }; + + check( $tmpl, \%hash ) or return; + + for my $mod (@$aref) { + my $obj = $cb->module_tree( $mod ); + + unless( $obj ) { + print "No such module '$mod'\n"; + next; + } + + my $opts = $mapping->{$cmd}; + $obj->install( %$opts ); + } + + return $aref; +} + +sub _shell { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my($aref, $cmd); + my $tmpl = { + result => { store => \$aref, default => [] }, + command => { required => 1, store => \$cmd }, + + }; + + check( $tmpl, \%hash ) or return; + + + my $shell = $conf->get_program('shell'); + unless( $shell ) { + print "Your configuration does not define a value for subshells.\n". + qq[Please define it with "o conf shell "\n]; + return; + } + + my $cwd = Cwd::cwd(); + + for my $mod (@$aref) { + print "Running $cmd for $mod\n"; + + my $obj = $cb->module_tree( $mod ) or next; + $obj->fetch or next; + $obj->extract or next; + + $cb->_chdir( dir => $obj->status->extract ) or next; + + local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; + if( system($shell) and $! ) { + print "Error executing your subshell '$shell': $!\n"; + next; + } + } + $cb->_chdir( dir => $cwd ); + + return $aref; +} + +sub _readme { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my($aref, $cmd); + my $tmpl = { + result => { store => \$aref, default => [] }, + command => { required => 1, store => \$cmd }, + + }; + + check( $tmpl, \%hash ) or return; + + for my $mod (@$aref) { + my $obj = $cb->module_tree( $mod ) or next; + + if( my $readme = $obj->readme ) { + + $self->_pager_open; + print $readme; + $self->_pager_close; + } + } + + return 1; +} + +sub _reload { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my($input, $cmd); + my $tmpl = { + input => { default => 'all', store => \$input }, + command => { required => 1, store => \$cmd }, + + }; + + check( $tmpl, \%hash ) or return; + + if ( $input =~ /cpan/i ) { + print qq[You want to reload the CPAN code\n]; + print qq[Just type 'q' and then restart... ] . + qq[Trust me, it is MUCH safer\n]; + + } elsif ( $input =~ /index/i ) { + $cb->reload_indices(update_source => 1); + + } else { + print qq[cpan re-evals the CPANPLUS.pm file\n]; + print qq[index re-reads the index files\n]; + } + + return 1; +} + +sub _autobundle { + my $self = shift; + my $cb = $self->backend; + + print qq[Writing bundle file... This may take a while\n]; + + my $where = $cb->autobundle(); + + print $where + ? qq[\nWrote autobundle to $where\n] + : qq[\nCould not create autobundle\n]; + + return 1; +} + +sub _set_conf { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my($aref, $input); + my $tmpl = { + result => { store => \$aref, default => [] }, + input => { default => 'all', store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + my $type = shift @$aref; + + if( $type eq 'debug' ) { + print qq[Sorry you cannot set debug options through ] . + qq[this shell in CPANPLUS\n]; + return; + + } elsif ( $type eq 'conf' ) { + + ### from CPAN.pm :o) + # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf' + # should have been called set and 'o debug' maybe 'set debug' + + # commit Commit changes to disk + # defaults Reload defaults from disk + # init Interactive setting of all options + + my $name = shift @$aref; + my $value = "@$aref"; + + if( $name eq 'init' ) { + my $setup = CPANPLUS::Configure::Setup->new( + conf => $cb->configure_object, + term => $self->term, + backend => $cb, + ); + return $setup->init; + + } elsif ($name eq 'commit' ) {; + $cb->configure_object->save; + print "Your CPAN++ configuration info has been saved!\n\n"; + return; + + } elsif ($name eq 'defaults' ) { + print qq[Sorry, CPANPLUS cannot restore default for you.\n] . + qq[Perhaps you should run the interactive setup again.\n] . + qq[\ttry running 'o conf init'\n]; + return; + + ### we're just supplying things in the 'conf' section now, + ### not the program section.. it's a bit of a hassle to make that + ### work cleanly with the original CPAN.pm interface, so we'll fix + ### it when people start complaining, which is hopefully never. + } else { + unless( $name ) { + my @list = grep { $_ ne 'hosts' } + $conf->options( type => $type ); + + my $method = 'get_' . $type; + + local $Data::Dumper::Indent = 0; + for my $name ( @list ) { + my $val = $conf->$method($name); + ($val) = ref($val) + ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) + : "'$val'"; + printf " %-25s %s\n", $name, $val; + } + + } elsif ( $name eq 'hosts' ) { + print "Setting hosts is not trivial.\n" . + "It is suggested you edit the " . + "configuration file manually"; + + } else { + my $method = 'set_' . $type; + if( $conf->$method($name => defined $value ? $value : '') ) { + my $set_to = defined $value ? $value : 'EMPTY STRING'; + print "Key '$name' was set to '$set_to'\n"; + } + } + } + } else { + print qq[Known options:\n] . + qq[ conf set or get configuration variables\n] . + qq[ debug set or get debugging options\n]; + } + + return; +} + +######################## +### search functions ### +######################## + +sub _author { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => ['/./'] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Author', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref; + + + my @rv; + for my $type (qw[author cpanid]) { + push @rv, $cb->search( type => $type, allow => \@regexes ); + } + + unless( @rv ) { + print "No object of type $class found for argument $input\n" + unless $short; + return; + } + + return $self->_pp_author( + result => \@rv, + class => $class, + short => $short, + input => $input ); + +} + +### find all modules matching a query ### +sub _module { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => ['/./'] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Module', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + my @rv; + for my $module (@$aref) { + if( $module =~ m|/(.+)/| ) { + push @rv, $cb->search( type => 'module', + allow => [qr/$1/i] ); + } else { + my $obj = $cb->module_tree( $module ) or next; + push @rv, $obj; + } + } + + return $self->_pp_module( + result => \@rv, + class => $class, + short => $short, + input => $input ); +} + +### find all bundles matching a query ### +sub _bundle { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => ['/./'] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Bundle', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + my @rv; + for my $bundle (@$aref) { + if( $bundle =~ m|/(.+)/| ) { + push @rv, $cb->search( type => 'module', + allow => [qr/Bundle::.*?$1/i] ); + } else { + my $obj = $cb->module_tree( "Bundle::${bundle}" ) or next; + push @rv, $obj; + } + } + + return $self->_pp_module( + result => \@rv, + class => $class, + short => $short, + input => $input ); +} + +sub _distribution { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => ['/./'] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Distribution', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + my @rv; + for my $module (@$aref) { + ### if it's a regex... ### + if ( my ($match) = $module =~ m|^/(.+)/$|) { + + ### something like /FOO/Bar.tar.gz/ was entered + if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) { + my $seen; + + my @data = $cb->search( type => 'package', + allow => [qr/$package/i] ); + + my @list = $cb->search( type => 'path', + allow => [qr/$path/i], + data => \@data ); + + ### make sure we dont list the same dist twice + for my $val ( @list ) { + next if $seen->{$val->package}++; + + push @rv, $val; + } + + ### something like /FOO/ or /Bar.tgz/ was entered + ### so we look both in the path, as well as in the package name + } else { + my $seen; + { my @list = $cb->search( type => 'package', + allow => [qr/$match/i] ); + + ### make sure we dont list the same dist twice + for my $val ( @list ) { + next if $seen->{$val->package}++; + + push @rv, $val; + } + } + + { my @list = $cb->search( type => 'path', + allow => [qr/$match/i] ); + + ### make sure we dont list the same dist twice + for my $val ( @list ) { + next if $seen->{$val->package}++; + + push @rv, $val; + } + + } + } + + } else { + + ### user entered a full dist, like: R/RC/RCAPUTO/POE-0.19.tar.gz + if (my ($path,$package) = $module =~ m|^/?(.+)/(.+)$|) { + my @data = $cb->search( type => 'package', + allow => [qr/^$package$/] ); + my @list = $cb->search( type => 'path', + allow => [qr/$path$/i], + data => \@data); + + ### make sure we dont list the same dist twice + my $seen; + for my $val ( @list ) { + next if $seen->{$val->package}++; + + push @rv, $val; + } + } + } + } + + return $self->_pp_distribution( + result => \@rv, + class => $class, + short => $short, + input => $input ); +} + +sub _find_all { + my $self = shift; + + my @rv; + for my $method (qw[_author _bundle _module _distribution]) { + my $aref = $self->$method( @_, short => 1 ); + + push @rv, @$aref if $aref; + } + + print scalar(@rv). " items found\n" +} + +sub _uptodate { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => ['/./'] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Uptodate', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + + my @rv; + if( @$aref) { + for my $module (@$aref) { + if( $module =~ m|/(.+)/| ) { + my @list = $cb->search( type => 'module', + allow => [qr/$1/i] ); + + ### only add those that are installed and not core + push @rv, grep { not $_->package_is_perl_core } + grep { $_->installed_file } + @list; + + } else { + my $obj = $cb->module_tree( $module ) or next; + push @rv, $obj; + } + } + } else { + @rv = @{$cb->_all_installed}; + } + + return $self->_pp_uptodate( + result => \@rv, + class => $class, + short => $short, + input => $input ); +} + +sub _ls { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my($aref, $short, $input, $class); + my $tmpl = { + result => { store => \$aref, default => [] }, + short => { default => 0, store => \$short }, + input => { default => 'all', store => \$input }, + class => { default => 'Uptodate', no_override => 1, + store => \$class }, + }; + + check( $tmpl, \%hash ) or return; + + my @rv; + for my $name (@$aref) { + my $auth = $cb->author_tree( uc $name ); + + unless( $auth ) { + print qq[ls command rejects argument $name: not an author\n]; + next; + } + + push @rv, $auth->distributions; + } + + return $self->_pp_ls( + result => \@rv, + class => $class, + short => $short, + input => $input ); +} + +############################ +### pretty printing subs ### +############################ + + +sub _pp_author { + my $self = shift; + my %hash = @_; + + my( $aref, $short, $class, $input ); + my $tmpl = { + result => { required => 1, default => [], strict_type => 1, + store => \$aref }, + short => { default => 0, store => \$short }, + class => { required => 1, store => \$class }, + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + ### no results + if( !@$aref ) { + print "No objects of type $class found for argument $input\n" + unless $short; + + ### one result, long output desired; + } elsif( @$aref == 1 and !$short ) { + + ### should look like this: + #cpan> a KANE + #Author id = KANE + # EMAIL boumans@frg.eur.nl + # FULLNAME Jos Boumans + + my $obj = shift @$aref; + + print "$class id = ", $obj->cpanid(), "\n"; + printf " %-12s %s\n", 'EMAIL', $obj->email(); + printf " %-12s %s%s\n", 'FULLNAME', $obj->author(); + + } else { + + ### should look like this: + #Author KANE (Jos Boumans) + #Author LBROCARD (Leon Brocard) + #2 items found + + for my $obj ( @$aref ) { + printf qq[%-15s %s ("%s" (%s))\n], + $class, $obj->cpanid, $obj->author, $obj->email; + } + print scalar(@$aref)." items found\n" unless $short; + } + + return $aref; +} + +sub _pp_module { + my $self = shift; + my %hash = @_; + + my( $aref, $short, $class, $input ); + my $tmpl = { + result => { required => 1, default => [], strict_type => 1, + store => \$aref }, + short => { default => 0, store => \$short }, + class => { required => 1, store => \$class }, + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + + ### no results + if( !@$aref ) { + print "No objects of type $class found for argument $input\n" + unless $short; + + ### one result, long output desired; + } elsif( @$aref == 1 and !$short ) { + + + ### should look like this: + #Module id = LWP + # DESCRIPTION Libwww-perl + # CPAN_USERID GAAS (Gisle Aas ) + # CPAN_VERSION 5.64 + # CPAN_FILE G/GA/GAAS/libwww-perl-5.64.tar.gz + # DSLI_STATUS RmpO (released,mailing-list,perl,object-oriented) + # MANPAGE LWP - The World-Wide Web library for Perl + # INST_FILE C:\Perl\site\lib\LWP.pm + # INST_VERSION 5.62 + + my $obj = shift @$aref; + my $aut_obj = $obj->author; + my $format = " %-12s %s%s\n"; + + print "$class id = ", $obj->module(), "\n"; + printf $format, 'DESCRIPTION', $obj->description() + if $obj->description(); + + printf $format, 'CPAN_USERID', $aut_obj->cpanid() . " (" . + $aut_obj->author() . " <" . $aut_obj->email() . ">)"; + + printf $format, 'CPAN_VERSION', $obj->version(); + printf $format, 'CPAN_FILE', $obj->path() . '/' . $obj->package(); + + printf $format, 'DSLI_STATUS', $self->_pp_dslip($obj->dslip) + if $obj->dslip() =~ /\w/; + + #printf $format, 'MANPAGE', $obj->foo(); + ### this is for bundles... CPAN.pm downloads them, + #printf $format, 'CONATAINS, + # parses and goes from there... + + printf $format, 'INST_FILE', $obj->installed_file || + '(not installed)'; + printf $format, 'INST_VERSION', $obj->installed_version; + + + + } else { + + ### should look like this: + #Module LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz) + #Module POE (R/RC/RCAPUTO/POE-0.19.tar.gz) + #2 items found + + for my $obj ( @$aref ) { + printf "%-15s %-15s (%s)\n", $class, $obj->module(), + $obj->path() .'/'. $obj->package(); + } + print scalar(@$aref). " items found\n" unless $short; + } + + return $aref; +} + +sub _pp_dslip { + my $self = shift; + my $dslip = shift or return; + + my (%_statusD, %_statusS, %_statusL, %_statusI); + + @_statusD{qw(? i c a b R M S)} = + qw(unknown idea pre-alpha alpha beta released mature standard); + + @_statusS{qw(? m d u n)} = + qw(unknown mailing-list developer comp.lang.perl.* none); + + @_statusL{qw(? p c + o h)} = qw(unknown perl C C++ other hybrid); + @_statusI{qw(? f r O h)} = + qw(unknown functions references+ties object-oriented hybrid); + + my @status = split("", $dslip); + + my $results = sprintf( "%s (%s,%s,%s,%s)", + $dslip, + $_statusD{$status[0]}, + $_statusS{$status[1]}, + $_statusL{$status[2]}, + $_statusI{$status[3]} + ); + + return $results; +} + +sub _pp_distribution { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my( $aref, $short, $class, $input ); + my $tmpl = { + result => { required => 1, default => [], strict_type => 1, + store => \$aref }, + short => { default => 0, store => \$short }, + class => { required => 1, store => \$class }, + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + + ### no results + if( !@$aref ) { + print "No objects of type $class found for argument $input\n" + unless $short; + + ### one result, long output desired; + } elsif( @$aref == 1 and !$short ) { + + + ### should look like this: + #Distribution id = S/SA/SABECK/POE-Component-Client-POP3-0.02.tar.gz + # CPAN_USERID SABECK (Scott Beck ) + # CONTAINSMODS POE::Component::Client::POP3 + + my $obj = shift @$aref; + my $aut_obj = $obj->author; + my $pkg = $obj->package; + my $format = " %-12s %s\n"; + + my @list = $cb->search( type => 'package', + allow => [qr/^$pkg$/] ); + + + print "$class id = ", $obj->path(), '/', $obj->package(), "\n"; + printf $format, 'CPAN_USERID', + $aut_obj->cpanid .' ('. $aut_obj->author . + ' '. $aut_obj->email .')'; + + ### yes i know it's ugly, but it's what cpan.pm does + printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list); + + } else { + + ### should look like this: + #Distribution LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz) + #Distribution POE (R/RC/RCAPUTO/POE-0.19.tar.gz) + #2 items found + + for my $obj ( @$aref ) { + printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package(); + } + + print scalar(@$aref). " items found\n" unless $short; + } + + return $aref; +} + +sub _pp_uptodate { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my( $aref, $short, $class, $input ); + my $tmpl = { + result => { required => 1, default => [], strict_type => 1, + store => \$aref }, + short => { default => 0, store => \$short }, + class => { required => 1, store => \$class }, + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + my $format = "%-25s %9s %9s %s\n"; + + my @not_uptodate; + my $no_version; + + my %seen; + for my $mod (@$aref) { + next if $mod->package_is_perl_core; + next if $seen{ $mod->package }++; + + + if( $mod->installed_file and not $mod->installed_version ) { + $no_version++; + next; + } + + push @not_uptodate, $mod unless $mod->is_uptodate; + } + + unless( @not_uptodate ) { + my $string = $input + ? "for $input" + : ''; + print "All modules are up to date $string\n"; + return; + + } else { + printf $format, ( 'Package namespace', + 'installed', + 'latest', + 'in CPAN file' + ); + } + + for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) { + printf $format, ( $mod->module, + $mod->installed_version, + $mod->version, + $mod->path .'/'. $mod->package, + ); + } + + print "$no_version installed modules have no (parsable) version number\n" + if $no_version; + + return \@not_uptodate; +} + +sub _pp_ls { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my( $aref, $short, $class, $input ); + my $tmpl = { + result => { required => 1, default => [], strict_type => 1, + store => \$aref }, + short => { default => 0, store => \$short }, + class => { required => 1, store => \$class }, + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + ### should look something like this: + #6272 2002-05-12 KANE/Acme-Comment-1.00.tar.gz + #8171 2002-08-13 KANE/Acme-Comment-1.01.zip + #7110 2002-09-04 KANE/Acme-Comment-1.02.tar.gz + #7571 2002-09-08 KANE/Acme-Intraweb-1.01.tar.gz + #6625 2001-08-23 KANE/Acme-POE-Knee-1.10.zip + #3058 2003-10-05 KANE/Acme-Test-0.02.tar.gz + + ### don't know size or mtime + #my $format = "%8d %10s %s/%s\n"; + + for my $mod ( sort { $a->package cmp $b->package } @$aref ) { + print "\t" . $mod->package . "\n"; + } + + return $aref; +} + + +############################# +### end pretty print subs ### +############################# + + +sub _bang { + my $self = shift; + my %hash = @_; + + my( $input ); + my $tmpl = { + input => { required => 1, store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + + eval $input; + warn $@ if $@; + + print "\n"; + + return; +} + +sub _help { + print qq[ +Display Information + a authors + b string display bundles + d or info distributions + m /regex/ about modules + i or anything of above + r none reinstall recommendations + u uninstalled distributions + +Download, Test, Make, Install... + get download + make make (implies get) + test modules, make test (implies make) + install dists, bundles make install (implies test) + clean make clean + look open subshell in these dists' directories + readme display these dists' README files + +Other + h,? display this menu ! perl-code eval a perl command + o conf [opt] set and query options q quit the cpan shell + reload cpan load CPAN.pm again reload index load newer indices + autobundle Snapshot force cmd unconditionally do cmd +]; + +} + + + +1; +__END__ + +=pod + +=head1 NAME + +CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS + +=head1 DESCRIPTION + +The Classic shell is designed to provide the feel of the CPAN.pm shell +using CPANPLUS underneath. + +For detailed documentation, refer to L. + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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, L, L + +=cut + + +=head1 SEE ALSO + +L + +=cut + + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/Shell/Default.pm b/lib/CPANPLUS/Shell/Default.pm new file mode 100644 index 0000000..c65cb88 --- /dev/null +++ b/lib/CPANPLUS/Shell/Default.pm @@ -0,0 +1,1699 @@ +package CPANPLUS::Shell::Default; + +use strict; + + +use CPANPLUS::Error; +use CPANPLUS::Backend; +use CPANPLUS::Configure::Setup; +use CPANPLUS::Internals::Constants; +use CPANPLUS::Internals::Constants::Report qw[GRADE_FAIL]; + +use Cwd; +use IPC::Cmd; +use Term::UI; +use Data::Dumper; +use Term::ReadLine; + +use Module::Load qw[load]; +use Params::Check qw[check]; +use Module::Load::Conditional qw[can_load check_install]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Params::Check::VERBOSE = 1; +local $Data::Dumper::Indent = 1; # for dumpering from ! + +BEGIN { + use vars qw[ $VERSION @ISA ]; + @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; + $VERSION = "0.78"; +} + +load CPANPLUS::Shell; + + +my $map = { + 'm' => '_search_module', + 'a' => '_search_author', + '!' => '_bang', + '?' => '_help', + 'h' => '_help', + 'q' => '_quit', + 'r' => '_readme', + 'v' => '_show_banner', + 'w' => '__display_results', + 'd' => '_fetch', + 'z' => '_shell', + 'f' => '_distributions', + 'x' => '_reload_indices', + 'i' => '_install', + 't' => '_install', + 'l' => '_details', + 'p' => '_print', + 's' => '_set_conf', + 'o' => '_uptodate', + 'b' => '_autobundle', + 'u' => '_uninstall', + '/' => '_meta', # undocumented for now + 'c' => '_reports', +}; +### free letters: e g j k n y ### + + +### will be filled if you have a .default-shell.rc and +### Config::Auto installed +my $rc = {}; + +### the shell object, scoped to the file ### +my $Shell; +my $Brand = loc('CPAN Terminal'); +my $Prompt = $Brand . '> '; + +=pod + +=head1 NAME + +CPANPLUS::Shell::Default + +=head1 SYNOPSIS + + ### loading the shell: + $ cpanp # run 'cpanp' from the command line + $ perl -MCPANPLUS -eshell # load the shell from the command line + + + use CPANPLUS::Shell qw[Default]; # load this shell via the API + # always done via CPANPLUS::Shell + + my $ui = CPANPLUS::Shell->new; + $ui->shell; # run the shell + $ui->dispatch_on_input( input => 'x'); # update the source using the + # dispatch method + + ### when in the shell: + ### Note that all commands can also take options. + ### Look at their underlying CPANPLUS::Backend methods to see + ### what options those are. + cpanp> h # show help messages + cpanp> ? # show help messages + + cpanp> m Acme # find acme modules, allows regexes + cpanp> a KANE # find modules by kane, allows regexes + cpanp> f Acme::Foo # get a list of all releases of Acme::Foo + + cpanp> i Acme::Foo # install Acme::Foo + cpanp> i Acme-Foo-1.3 # install version 1.3 of Acme::Foo + cpanp> i # install from URI, like ftp://foo.com/X.tgz + cpanp> i 1 3..5 # install search results 1, 3, 4 and 5 + cpanp> i * # install all search results + cpanp> a KANE; i *; # find modules by kane, install all results + cpanp> t Acme::Foo # test Acme::Foo, without installing it + cpanp> u Acme::Foo # uninstall Acme::Foo + cpanp> d Acme::Foo # download Acme::Foo + cpanp> z Acme::Foo # download & extract Acme::Foo, then open a + # shell in the extraction directory + + cpanp> c Acme::Foo # get a list of test results for Acme::Foo + cpanp> l Acme::Foo # view details about the Acme::Foo package + cpanp> r Acme::Foo # view Acme::Foo's README file + cpanp> o # get a list of all installed modules that + # are out of date + cpanp> o 1..3 # list uptodateness from a previous search + + cpanp> s conf # show config settings + cpanp> s conf md5 1 # enable md5 checks + cpanp> s program # show program settings + cpanp> s edit # edit config file + cpanp> s reconfigure # go through initial configuration again + cpanp> s selfupdate # update your CPANPLUS install + cpanp> s save # save config to disk + cpanp> s mirrors # show currently selected mirrors + + cpanp> ! [PERL CODE] # execute the following perl code + + cpanp> b # create an autobundle for this computers + # perl installation + cpanp> x # reload index files (purges cache) + cpanp> x --update_source # reload index files, get fresh source files + cpanp> p [FILE] # print error stack (to a file) + cpanp> v # show the banner + cpanp> w # show last search results again + + cpanp> q # quit the shell + + cpanp> /plugins # list avialable plugins + cpanp> /? PLUGIN # list help test of + + ### common options: + cpanp> i ... --skiptest # skip tests + cpanp> i ... --force # force all operations + cpanp> i ... --verbose # run in verbose mode + +=head1 DESCRIPTION + +This module provides the default user interface to C. You +can start it via the C binary, or as detailed in the L. + +=cut + +sub new { + my $class = shift; + + my $cb = new CPANPLUS::Backend; + my $self = $class->SUPER::_init( + brand => $Brand, + term => Term::ReadLine->new( $Brand ), + prompt => $Prompt, + backend => $cb, + format => "%4s %-55s %8s %-10s\n", + dist_format => "%4s %-42s %-12s %8s %-10s\n", + ); + ### make it available package wide ### + $Shell = $self; + + my $rc_file = File::Spec->catfile( + $cb->configure_object->get_conf('base'), + DOT_SHELL_DEFAULT_RC, + ); + + + if( -e $rc_file && -r _ ) { + $rc = _read_configuration_from_rc( $rc_file ); + } + + ### register install callback ### + $cb->_register_callback( + name => 'install_prerequisite', + code => \&__ask_about_install, + ); + + ### execute any login commands specified ### + $self->dispatch_on_input( input => $rc->{'login'} ) + if defined $rc->{'login'}; + + ### register test report callbacks ### + $cb->_register_callback( + name => 'edit_test_report', + code => \&__ask_about_edit_test_report, + ); + + $cb->_register_callback( + name => 'send_test_report', + code => \&__ask_about_send_test_report, + ); + + + return $self; +} + +sub shell { + my $self = shift; + my $term = $self->term; + my $conf = $self->backend->configure_object; + + $self->_show_banner; + print "*** Type 'p' now to show start up log\n"; # XXX add to banner? + $self->_show_random_tip if $conf->get_conf('show_startup_tip'); + $self->_input_loop && print "\n"; + $self->_quit; +} + +sub _input_loop { + my $self = shift; + my $term = $self->term; + my $cb = $self->backend; + + my $normal_quit = 0; + while ( + defined (my $input = eval { $term->readline($self->prompt) } ) + or $self->_signals->{INT}{count} == 1 + ) { + ### re-initiate all signal handlers + while (my ($sig, $entry) = each %{$self->_signals} ) { + $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); + } + + print "\n"; + last if $self->dispatch_on_input( input => $input ); + + ### flush the lib cache ### + $cb->_flush( list => [qw|lib load|] ); + + } continue { + $self->_signals->{INT}{count}-- + if $self->_signals->{INT}{count}; # clear the sigint count + } + + return 1; +} + +### return 1 to quit ### +sub dispatch_on_input { + my $self = shift; + my $conf = $self->backend->configure_object(); + my $term = $self->term; + my %hash = @_; + + my($string, $noninteractive); + my $tmpl = { + input => { required => 1, store => \$string }, + noninteractive => { required => 0, store => \$noninteractive }, + }; + + check( $tmpl, \%hash ) or return; + + ### indicates whether or not the user will receive a shell + ### prompt after the command has finished. + $self->noninteractive($noninteractive) if defined $noninteractive; + + my @cmds = split ';', $string; + while( my $input = shift @cmds ) { + + ### to send over the socket ### + my $org_input = $input; + + my $key; my $options; + { ### make whitespace not count when using special chars + { $input =~ s|^\s*([!?/])|$1 |; } + + ### get the first letter of the input + $input =~ s|^\s*([\w\?\!/])\w*||; + + chomp $input; + $key = lc($1); + + ### we figured out what the command was... + ### if we have more input, that DOES NOT start with a white + ### space char, we misparsed.. like 'Test::Foo::Bar', which + ### would turn into 't', '::Foo::Bar'... + if( $input and $input !~ s/^\s+// ) { + print loc("Could not understand command: %1\n". + "Possibly missing command before argument(s)?\n", + $org_input); + return; + } + + ### allow overrides from the config file ### + if( defined $rc->{$key} ) { + $input = $rc->{$key} . $input; + } + + ### grab command line options like --no-force and --verbose ### + ($options,$input) = $term->parse_options($input) + unless $key eq '!'; + } + + ### emtpy line? ### + return unless $key; + + ### time to quit ### + return 1 if $key eq 'q'; + + my $method = $map->{$key}; + + ### dispatch meta locally at all times ### + $self->$method(input => $input, options => $options), next + if $key eq '/'; + + ### flush unless we're trying to print the stack + CPANPLUS::Error->flush unless $key eq 'p'; + + ### connected over a socket? ### + if( $self->remote ) { + + ### unsupported commands ### + if( $key eq 'z' or + ($key eq 's' and $input =~ /^\s*edit/) + ) { + print "\n", loc("Command not supported over remote connection"), + "\n\n"; + + } else { + my($status,$buff) = $self->__send_remote_command($org_input); + + print "\n", loc("Command failed!"), "\n\n" unless $status; + + $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount; + print $buff; + $self->_pager_close; + } + + ### or just a plain local shell? ### + } else { + + unless( $self->can($method) ) { + print loc("Unknown command '%1'. Usage:", $key), "\n"; + $self->_help; + + } else { + + ### some methods don't need modules ### + my @mods; + @mods = $self->_select_modules($input) + unless grep {$key eq $_} qw[! m a v w x p s b / ? h]; + + eval { $self->$method( modules => \@mods, + options => $options, + input => $input, + choice => $key ) + }; + error( $@ ) if $@; + } + } + } + + return; +} + +sub _select_modules { + my $self = shift; + my $input = shift or return; + my $cache = $self->cache; + my $cb = $self->backend; + + ### expand .. in $input + $input =~ s{\b(\d+)\s*\.\.\s*(\d+)\b} + {join(' ', ($1 < 1 ? 1 : $1) .. ($2 > $#{$cache} ? $#{$cache} : $2))}eg; + + $input = join(' ', 1 .. $#{$cache}) if $input eq '*'; + $input =~ s/'/::/g; # perl 4 convention + + my @rv; + for my $mod (split /\s+/, $input) { + + ### it's a cache look up ### + if( $mod =~ /^\d+/ and $mod > 0 ) { + unless( scalar @$cache ) { + print loc("No search was done yet!"), "\n"; + + } elsif ( my $obj = $cache->[$mod] ) { + push @rv, $obj; + + } else { + print loc("No such module: %1", $mod), "\n"; + } + + } else { + my $obj = $cb->parse_module( module => $mod ); + + unless( $obj ) { + print loc("No such module: %1", $mod), "\n"; + + } else { + push @rv, $obj; + } + } + } + + unless( scalar @rv ) { + print loc("No modules found to operate on!\n"); + return; + } else { + return @rv; + } +} + +sub _format_version { + my $self = shift; + my $version = shift; + + ### fudge $version into the 'optimal' format + $version = 0 if $version eq 'undef'; + $version =~ s/_//g; # everything after gets stripped off otherwise + + ### allow 6 digits after the dot, as that's how perl stringifies + ### x.y.z numbers. + $version = sprintf('%3.6f', $version); + $version = '' if $version == '0.00'; + $version =~ s/(00{0,3})$/' ' x (length $1)/e; + + return $version; +} + +sub __display_results { + my $self = shift; + my $cache = $self->cache; + + my @rv = @$cache; + + if( scalar @rv ) { + + $self->_pager_open if $#{$cache} >= $self->_term_rowcount; + + my $i = 1; + for my $mod (@rv) { + next unless $mod; # first one is undef + # humans start counting at 1 + + ### for dists only -- we have checksum info + if( $mod->mtime ) { + printf $self->dist_format, + $i, + $mod->module, + $mod->mtime, + $self->_format_version($mod->version), + $mod->author->cpanid(); + + } else { + printf $self->format, + $i, + $mod->module, + $self->_format_version($mod->version), + $mod->author->cpanid(); + } + $i++; + } + + $self->_pager_close; + + } else { + print loc("No results to display"), "\n"; + } +} + + +sub _quit { + my $self = shift; + + $self->dispatch_on_input( input => $rc->{'logout'} ) + if defined $rc->{'logout'}; + + print loc("Exiting CPANPLUS shell"), "\n"; +} + +########################### +### actual command subs ### +########################### + + +### print out the help message ### +### perhaps, '?' should be a slightly different version ### +my @Help; +sub _help { + my $self = shift; + my %hash = @_; + + my $input; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + input => { required => 0, store => \$input } + }; + + my $args = check( $tmpl, \%hash ) or return; + } + + @Help = ( +loc('[General]' ), +loc(' h | ? # display help' ), +loc(' q # exit' ), +loc(' v # version information' ), +loc('[Search]' ), +loc(' a AUTHOR ... # search by author(s)' ), +loc(' m MODULE ... # search by module(s)' ), +loc(' f MODULE ... # list all releases of a module' ), +loc(" o [ MODULE ... ] # list installed module(s) that aren't up to date" ), +loc(' w # display the result of your last search again' ), +loc('[Operations]' ), +loc(' i MODULE | NUMBER ... # install module(s), by name or by search number' ), +loc(' i URI | ... # install module(s), by URI (ie http://foo.com/X.tgz)' ), +loc(' t MODULE | NUMBER ... # test module(s), by name or by search number' ), +loc(' u MODULE | NUMBER ... # uninstall module(s), by name or by search number' ), +loc(' d MODULE | NUMBER ... # download module(s)' ), +loc(' l MODULE | NUMBER ... # display detailed information about module(s)' ), +loc(' r MODULE | NUMBER ... # display README files of module(s)' ), +loc(' c MODULE | NUMBER ... # check for module report(s) from cpan-testers' ), +loc(' z MODULE | NUMBER ... # extract module(s) and open command prompt in it' ), +loc('[Local Administration]' ), +loc(' b # write a bundle file for your configuration' ), +loc(' s program [OPT VALUE] # set program locations for this session' ), +loc(' s conf [OPT VALUE] # set config options for this session' ), +loc(' s mirrors # show currently selected mirrors' ), +loc(' s reconfigure # reconfigure settings ' ), +loc(' s selfupdate # update your CPANPLUS install '), +loc(' s save [user|system] # save settings for this user or systemwide' ), +loc(' s edit [user|system] # open configuration file in editor and reload' ), +loc(' ! EXPR # evaluate a perl statement' ), +loc(' p [FILE] # print the error stack (optionally to a file)' ), +loc(' x # reload CPAN indices (purges cache)' ), +loc(' x --update_source # reload CPAN indices, get fresh source files' ), +loc('[Plugins]' ), +loc(' /plugins # list available plugins' ), +loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ), + + ) unless @Help; + + $self->_pager_open if (@Help >= $self->_term_rowcount); + ### XXX: functional placeholder for actual 'detailed' help. + print "Detailed help for the command '$input' is not available.\n\n" + if length $input; + print map {"$_\n"} @Help; + print $/; + $self->_pager_close; +} + +### eval some code ### +sub _bang { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + + my $input; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + input => { required => 1, store => \$input } + }; + + my $args = check( $tmpl, \%hash ) or return; + } + + local $Data::Dumper::Indent = 1; # for dumpering from ! + eval $input; + error( $@ ) if $@; + print "\n"; + return; +} + +sub _search_module { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $args; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + input => { required => 1, }, + options => { default => { } }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'}; + + ### XXX this is rather slow, because (probably) + ### of the many method calls + ### XXX need to profile to speed it up =/ + + ### find the modules ### + my @rv = sort { $a->module cmp $b->module } + $cb->search( + %{$args->{'options'}}, + type => 'module', + allow => \@regexes, + ); + + ### store the result in the cache ### + $self->cache([undef,@rv]); + + $self->__display_results; + + return 1; +} + +sub _search_author { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $args; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + input => { required => 1, }, + options => { default => { } }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'}; + + my @rv; + for my $type (qw[author cpanid]) { + push @rv, $cb->search( + %{$args->{'options'}}, + type => $type, + allow => \@regexes, + ); + } + + my %seen; + my @list = sort { $a->module cmp $b->module } + grep { defined } + map { $_->modules } + grep { not $seen{$_}++ } @rv; + + $self->cache([undef,@list]); + + $self->__display_results; + return 1; +} + +sub _readme { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $args; my $mods; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + return unless scalar @$mods; + + $self->_pager_open; + for my $mod ( @$mods ) { + print $mod->readme( %$opts ); + } + + $self->_pager_close; + + return 1; +} + +sub _fetch { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $args; my $mods; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + $self->_pager_open if @$mods >= $self->_term_rowcount; + for my $mod (@$mods) { + my $where = $mod->fetch( %$opts ); + + print $where + ? loc("Successfully fetched '%1' to '%2'", + $mod->module, $where ) + : loc("Failed to fetch '%1'", $mod->module); + print "\n"; + } + $self->_pager_close; + +} + +sub _shell { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my $shell = $conf->get_program('shell'); + unless( $shell ) { + print loc("Your config does not specify a subshell!"), "\n", + loc("Perhaps you need to re-run your setup?"), "\n"; + return; + } + + my $args; my $mods; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my $cwd = Cwd::cwd(); + for my $mod (@$mods) { + $mod->fetch( %$opts ) or next; + $mod->extract( %$opts ) or next; + + $cb->_chdir( dir => $mod->status->extract() ) or next; + + #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; + + if( system($shell) and $! ) { + print loc("Error executing your subshell '%1': %2", + $shell, $!),"\n"; + next; + } + } + $cb->_chdir( dir => $cwd ); + + return 1; +} + +sub _distributions { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my $args; my $mods; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my @list; + for my $mod (@$mods) { + push @list, sort { $a->version <=> $b->version } + grep { defined } $mod->distributions( %$opts ); + } + + my @rv = sort { $a->module cmp $b->module } @list; + + $self->cache([undef,@rv]); + $self->__display_results; + + return; 1; +} + +sub _reload_indices { + my $self = shift; + my $cb = $self->backend; + my %hash = @_; + + my $args; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my $rv = $cb->reload_indices( %$opts ); + + ### so the update failed, but you didnt give it any options either + if( !$rv and !(keys %$opts) ) { + print "\nFailure may be due to corrupt source files\n" . + "Try this:\n\tx --update_source\n\n"; + } + + return $rv; + +} + +sub _install { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my $args; my $mods; my $opts; my $choice; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + choice => { required => 1, store => \$choice, + allow => [qw|i t|] }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + unless( scalar @$mods ) { + print loc("Nothing done\n"); + return; + } + + my $target = $choice eq 'i' ? TARGET_INSTALL : TARGET_CREATE; + my $prompt = $choice eq 'i' ? loc('Installing ') : loc('Testing '); + my $action = $choice eq 'i' ? 'install' : 'test'; + + my $status = {}; + ### first loop over the mods to install them ### + for my $mod (@$mods) { + print $prompt, $mod->module, "\n"; + + my $log_length = length CPANPLUS::Error->stack_as_string; + + ### store the status for look up when we're done with all + ### install calls + $status->{$mod} = $mod->install( %$opts, target => $target ); + + ### would you like a log file of what happened? + if( $conf->get_conf('write_install_logs') ) { + + my $dir = File::Spec->catdir( + $conf->get_conf('base'), + $conf->_get_build('install_log_dir'), + ); + ### create the dir if it doesn't exit yet + $cb->_mkdir( dir => $dir ) unless -d $dir; + + my $file = File::Spec->catfile( + $dir, + INSTALL_LOG_FILE->( $mod ) + ); + if ( open my $fh, ">$file" ) { + my $stack = CPANPLUS::Error->stack_as_string; + ### remove everything in the log that was there *before* + ### we started this install + substr( $stack, 0, $log_length, '' ); + + print $fh $stack; + close $fh; + + print loc("*** Install log written to:\n %1\n\n", $file); + } else { + warn "Could not open '$file': $!\n"; + next; + } + } + } + + my $flag; + ### then report whether all this went ok or not ### + for my $mod (@$mods) { + # if( $mod->status->installed ) { + if( $status->{$mod} ) { + print loc("Module '%1' %tense(%2,past) successfully\n", + $mod->module, $action) + } else { + $flag++; + print loc("Error %tense(%1,present) '%2'\n", + $action, $mod->module); + } + } + + + + if( !$flag ) { + print loc("No errors %tense(%1,present) all modules", $action), "\n"; + } else { + print loc("Problem %tense(%1,present) one or more modules", $action); + print "\n"; + print loc("*** You can view the complete error buffer by pressing '%1' ***\n", 'p') + unless $conf->get_conf('verbose') || $self->noninteractive; + } + print "\n"; + + return !$flag; +} + +sub __ask_about_install { + my $mod = shift or return; + my $prereq = shift or return; + my $term = $Shell->term; + + print "\n"; + print loc( "Module '%1' requires '%2' to be installed", + $mod->module, $prereq->module ); + print "\n\n"; + print loc( "If you don't wish to see this question anymore\n". + "you can disable it by entering the following ". + "commands on the prompt:\n '%1'", + 's conf prereqs 1; s save' ); + print "\n\n"; + + my $bool = $term->ask_yn( + prompt => loc("Should I install this module?"), + default => 'y' + ); + + return $bool; +} + +sub __ask_about_send_test_report { + my($mod, $grade) = @_; + return 1 unless $grade eq GRADE_FAIL; + + my $term = $Shell->term; + + print "\n"; + print loc( "Test report prepared for module '%1'.\n Would you like to ". + "send it? (You can edit it if you like)", $mod->module ); + print "\n\n"; + my $bool = $term->ask_yn( + prompt => loc("Would you like to send the test report?"), + default => 'n' + ); + + return $bool; +} + +sub __ask_about_edit_test_report { + my($mod, $grade) = @_; + return 0 unless $grade eq GRADE_FAIL; + + my $term = $Shell->term; + + print "\n"; + print loc( "Test report prepared for module '%1'. You can edit this ". + "report if you would like", $mod->module ); + print "\n\n"; + my $bool = $term->ask_yn( + prompt => loc("Would you like to edit the test report?"), + default => 'y' + ); + + return $bool; +} + + + +sub _details { + my $self = shift; + my $cb = $self->backend; + my $conf = $cb->configure_object; + my %hash = @_; + + my $args; my $mods; my $opts; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + modules => { required => 1, store => \$mods }, + options => { default => { }, store => \$opts }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + ### every module has about 10 lines of details + ### maybe more later with Module::CPANTS etc + $self->_pager_open if scalar @$mods * 10 > $self->_term_rowcount; + + + my $format = "%-30s %-30s\n"; + for my $mod (@$mods) { + my $href = $mod->details( %$opts ); + my @list = sort { $a->module cmp $b->module } $mod->contains; + + unless( $href ) { + print loc("No details for %1 - it might be outdated.", + $mod->module), "\n"; + next; + + } else { + print loc( "Details for '%1'\n", $mod->module ); + for my $item ( sort keys %$href ) { + printf $format, $item, $href->{$item}; + } + + my $showed; + for my $item ( @list ) { + printf $format, ($showed ? '' : 'Contains:'), $item->module; + $showed++; + } + print "\n"; + } + } + $self->_pager_close; + print "\n"; + + return 1; +} + +sub _print { + my $self = shift; + my %hash = @_; + + my $args; my $opts; my $file; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + input => { default => '', store => \$file }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my $old; my $fh; + if( $file ) { + $fh = FileHandle->new( ">$file" ) + or( warn loc("Could not open '%1': '%2'", $file, $!), + return + ); + $old = select $fh; + } + + + $self->_pager_open if !$file; + + print CPANPLUS::Error->stack_as_string; + + $self->_pager_close; + + select $old if $old; + print "\n"; + + return 1; +} + +sub _set_conf { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $conf = $cb->configure_object; + + ### possible options + ### XXX hard coded, not optimal :( + my @types = qw[reconfigure save edit program conf mirrors selfupdate]; + + + my $args; my $opts; my $input; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + input => { default => '', store => \$input }, + }; + + $args = check( $tmpl, \%hash ) or return; + } + + my ($type,$key,$value) = $input =~ m/(\w+)\s*(\w*)\s*(.*?)\s*$/; + $type = lc $type; + + if( $type eq 'reconfigure' ) { + my $setup = CPANPLUS::Configure::Setup->new( + configure_object => $conf, + term => $self->term, + backend => $cb, + ); + return $setup->init; + + } elsif ( $type eq 'save' ) { + my $where = { + user => CONFIG_USER, + system => CONFIG_SYSTEM, + }->{ $key } || CONFIG_USER; + + my $rv = $cb->configure_object->save( $where ); + + print $rv + ? loc("Configuration successfully saved to %1\n", $where) + : loc("Failed to save configuration\n" ); + return $rv; + + } elsif ( $type eq 'edit' ) { + + my $editor = $conf->get_program('editor') + or( print(loc("No editor specified")), return ); + + my $where = { + user => CONFIG_USER, + system => CONFIG_SYSTEM, + }->{ $key } || CONFIG_USER; + + my $file = $conf->_config_pm_to_file( $where ); + system("$editor $file"); + + ### now reload it + ### disable warnings for this + { require Module::Loaded; + Module::Loaded::mark_as_unloaded( $_ ) for $conf->configs; + + ### reinitialize the config + local $^W; + $conf->init; + } + + return 1; + + } elsif ( $type eq 'mirrors' ) { + + print loc("Readonly list of mirrors (in order of preference):\n\n" ); + + my $i; + for my $host ( @{$conf->get_conf('hosts')} ) { + my $uri = $cb->_host_to_uri( %$host ); + + $i++; + print "\t[$i] $uri\n"; + } + + } elsif ( $type eq 'selfupdate' ) { + my %valid = map { $_ => $_ } + qw|core dependencies enabled_features features all|; + + unless( $valid{$key} ) { + print loc( "To update your current CPANPLUS installation, ". + "choose one of the these options:\n%1", + (join $/, map {"\ts selfupdate $_"} sort keys %valid) ); + } else { + print loc( "Updating your CPANPLUS installation\n" ); + $cb->selfupdate_object->selfupdate( + update => $key, + latest => 1, + %$opts + ); + } + + } else { + + if ( $type eq 'program' or $type eq 'conf' ) { + + my $format = { + conf => '%-25s %s', + program => '%-12s %s', + }->{ $type }; + + unless( $key ) { + my @list = grep { $_ ne 'hosts' } + $conf->options( type => $type ); + + my $method = 'get_' . $type; + + local $Data::Dumper::Indent = 0; + for my $name ( @list ) { + my $val = $conf->$method($name) || ''; + ($val) = ref($val) + ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) + : "'$val'"; + printf " $format\n", $name, $val; + } + + } elsif ( $key eq 'hosts' ) { + print loc( "Setting hosts is not trivial.\n" . + "It is suggested you use '%1' and edit the " . + "configuration file manually", 's edit'); + } else { + my $method = 'set_' . $type; + $conf->$method( $key => defined $value ? $value : '' ) + and print loc("Key '%1' was set to '%2'", $key, + defined $value ? $value : 'EMPTY STRING'); + } + + } else { + print loc("Unknown type '%1'",$type || 'EMPTY' ); + print $/; + print loc("Try one of the following:"); + print $/, join $/, map { "\t'$_'" } sort @types; + } + } + print "\n"; + return 1; +} + +sub _uptodate { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $conf = $cb->configure_object; + + my $opts; my $mods; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + modules => { required => 1, store => \$mods }, + }; + + check( $tmpl, \%hash ) or return; + } + + ### long listing? short is default ### + my $long = $opts->{'long'} ? 1 : 0; + + my @list = scalar @$mods ? @$mods : @{$cb->_all_installed}; + + my @rv; my %seen; + for my $mod (@list) { + ### skip this mod if it's up to date ### + next if $mod->is_uptodate; + ### skip this mod if it's core ### + next if $mod->package_is_perl_core; + + if( $long or !$seen{$mod->package}++ ) { + push @rv, $mod; + } + } + + @rv = sort { $a->module cmp $b->module } @rv; + + $self->cache([undef,@rv]); + + $self->_pager_open if scalar @rv >= $self->_term_rowcount; + + my $format = "%5s %12s %12s %-36s %-10s\n"; + + my $i = 1; + for my $mod ( @rv ) { + printf $format, + $i, + $self->_format_version($mod->installed_version) || 'Unparsable', + $self->_format_version( $mod->version ), + $mod->module, + $mod->author->cpanid(); + $i++; + } + $self->_pager_close; + + return 1; +} + +sub _autobundle { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $conf = $cb->configure_object; + + my $opts; my $input; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + input => { default => '', store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + } + + $opts->{'path'} = $input if $input; + + my $where = $cb->autobundle( %$opts ); + + print $where + ? loc("Wrote autobundle to '%1'", $where) + : loc("Could not create autobundle" ); + print "\n"; + + return $where ? 1 : 0; +} + +sub _uninstall { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $term = $self->term; + my $conf = $cb->configure_object; + + my $opts; my $mods; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + modules => { default => [], store => \$mods }, + }; + + check( $tmpl, \%hash ) or return; + } + + my $force = $opts->{'force'} || $conf->get_conf('force'); + + unless( $force ) { + my $list = join "\n", map { ' ' . $_->module } @$mods; + + print loc(" +This will uninstall the following modules: +%1 + +Note that if you installed them via a package manager, you probably +should use the same package manager to uninstall them + +", $list); + + return unless $term->ask_yn( + prompt => loc("Are you sure you want to continue?"), + default => 'n', + ); + } + + ### first loop over all the modules to uninstall them ### + for my $mod (@$mods) { + print loc("Uninstalling '%1'", $mod->module), "\n"; + + $mod->uninstall( %$opts ); + } + + my $flag; + ### then report whether all this went ok or not ### + for my $mod (@$mods) { + if( $mod->status->uninstall ) { + print loc("Module '%1' %tense(uninstall,past) successfully\n", + $mod->module ) + } else { + $flag++; + print loc("Error %tense(uninstall,present) '%1'\n", $mod->module); + } + } + + if( !$flag ) { + print loc("All modules %tense(uninstall,past) successfully"), "\n"; + } else { + print loc("Problem %tense(uninstalling,present) one or more modules" ), + "\n"; + print loc("*** You can view the complete error buffer by pressing '%1'". + "***\n", 'p') unless $conf->get_conf('verbose'); + } + print "\n"; + + return !$flag; +} + +sub _reports { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $term = $self->term; + my $conf = $cb->configure_object; + + my $opts; my $mods; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + modules => { default => '', store => \$mods }, + }; + + check( $tmpl, \%hash ) or return; + } + + ### XXX might need to be conditional ### + $self->_pager_open; + + for my $mod (@$mods) { + my @list = $mod->fetch_report( %$opts ) + or( print(loc("No reports available for this distribution.")), + next + ); + + @list = reverse + map { $_->[0] } + sort { $a->[1] cmp $b->[1] } + map { [$_, $_->{'dist'}.':'.$_->{'platform'}] } @list; + + + + ### XXX this may need to be sorted better somehow ### + my $url; + my $format = "%8s %s %s\n"; + + my %seen; + for my $href (@list ) { + print "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n" + unless $seen{ $href->{'dist'} }++; + + printf $format, $href->{'grade'}, $href->{'platform'}, + ($href->{'details'} ? '(*)' : ''); + + $url ||= $href->{'details'}; + } + + print "\n==> $url\n" if $url; + print "\n"; + } + $self->_pager_close; + + return 1; +} + + +### Load plugins +{ my @PluginModules; + my %Dispatch = ( + showtip => [ __PACKAGE__, '_show_random_tip'], + plugins => [ __PACKAGE__, '_list_plugins' ], + '?' => [ __PACKAGE__, '_plugins_usage' ], + ); + + sub plugin_modules { return @PluginModules } + sub plugin_table { return %Dispatch } + + ### find all plugins first + if( check_install( module => 'Module::Pluggable', version => '2.4') ) { + require Module::Pluggable; + + my $only_re = __PACKAGE__ . '::Plugins::\w+$'; + + Module::Pluggable->import( + sub_name => '_plugins', + search_path => __PACKAGE__, + only => qr/$only_re/, + #except => [ INSTALLER_MM, INSTALLER_SAMPLE ] + ); + + push @PluginModules, __PACKAGE__->_plugins; + } + + ### now try to load them + for my $p ( __PACKAGE__->plugin_modules ) { + my %map = eval { load $p; $p->import; $p->plugins }; + error(loc("Could not load plugin '$p': $@")), next if $@; + + ### register each plugin + while( my($name, $func) = each %map ) { + + if( not length $name or not length $func ) { + error(loc("Empty plugin name or dispatch function detected")); + next; + } + + if( exists( $Dispatch{$name} ) ) { + error(loc("'%1' is already registered by '%2'", + $name, $Dispatch{$name}->[0])); + next; + } + + ### register name, package and function + $Dispatch{$name} = [ $p, $func ]; + } + } + + ### dispatch a plugin command to it's function + sub _meta { + my $self = shift; + my %hash = @_; + my $cb = $self->backend; + my $term = $self->term; + my $conf = $cb->configure_object; + + my $opts; my $input; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + options => { default => { }, store => \$opts }, + input => { default => '', store => \$input }, + }; + + check( $tmpl, \%hash ) or return; + } + + $input =~ s/\s*(\S+)\s*//; + my $cmd = $1; + + ### look up the command, or go to the default + my $aref = $Dispatch{ $cmd } || [ __PACKAGE__, '_plugin_default' ]; + + my($pkg,$func) = @$aref; + + my $rv = eval { $pkg->$func( $self, $cb, $cmd, $input, $opts ) }; + + error( $@ ) if $@; + + ### return $rv instead, so input loop can be terminated? + return 1; + } + + sub _plugin_default { error(loc("No such plugin command")) } +} + +### plugin commands +{ my $help_format = " /%-20s # %s\n"; + + sub _list_plugins { + print loc("Available plugins:\n"); + print loc(" List usage by using: /? PLUGIN_NAME\n" ); + print $/; + + my %table = __PACKAGE__->plugin_table; + for my $name( sort keys %table ) { + my $pkg = $table{$name}->[0]; + my $this = __PACKAGE__; + + my $who = $pkg eq $this + ? "Standard Plugin" + : do { $pkg =~ s/^$this/../; "Provided by: $pkg" }; + + printf $help_format, $name, $who; + } + + print $/.$/; + + print " Write your own plugins? Read the documentation of:\n" . + " CPANPLUS::Shell::Default::Plugins::HOWTO\n"; + + print $/; + } + + sub _list_plugins_help { + return sprintf $help_format, 'plugins', loc("lists available plugins"); + } + + ### registered as a plugin too + sub _show_random_tip_help { + return sprintf $help_format, 'showtip', loc("show usage tips" ); + } + + sub _plugins_usage { + my $pkg = shift; + my $shell = shift; + my $cb = shift; + my $cmd = shift; + my $input = shift; + my %table = __PACKAGE__->plugin_table; + + my @list = length $input ? split /\s+/, $input : sort keys %table; + + for my $name( @list ) { + + ### no such plugin? skip + error(loc("No such plugin '$name'")), next unless $table{$name}; + + my $pkg = $table{$name}->[0]; + my $func = $table{$name}->[1] . '_help'; + + if ( my $sub = $pkg->can( $func ) ) { + eval { print $sub->() }; + error( $@ ) if $@; + + } else { + print " No usage for '$name' -- try perldoc $pkg"; + } + + print $/; + } + + print $/.$/; + } + + sub _plugins_usage_help { + return sprintf $help_format, '? [NAME ...]', + loc("show usage for plugins"); + } +} + +### send a command to a remote host, retrieve the answer; +sub __send_remote_command { + my $self = shift; + my $cmd = shift; + my $remote = $self->remote or return; + my $user = $remote->{'username'}; + my $pass = $remote->{'password'}; + my $conn = $remote->{'connection'}; + my $end = "\015\012"; + my $answer; + + my $send = join "\0", $user, $pass, $cmd; + + print $conn $send . $end; + + ### XXX why doesn't something like this just work? + #1 while recv($conn, $answer, 1024, 0); + while(1) { + my $buff; + $conn->recv( $buff, 1024, 0 ); + $answer .= $buff; + last if $buff =~ /$end$/; + } + + my($status,$buffer) = split "\0", $answer; + + return ($status, $buffer); +} + + +sub _read_configuration_from_rc { + my $rc_file = shift; + + my $href; + if( can_load( modules => { 'Config::Auto' => '0.0' } ) ) { + $Config::Auto::DisablePerl = 1; + + eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) }; + + print loc( "Unable to read in config file '%1': %2", + $rc_file, $@ ) if $@; + } + + return $href || {}; +} + +{ my @tips = ( + loc( "You can update CPANPLUS by running: '%1'", 's selfupdate' ), + loc( "You can install modules by URL using '%1'", 'i URL' ), + loc( "You can turn off these tips using '%1'", + 's conf show_startup_tip 0' ), + loc( "You can use wildcards like '%1' and '%2' on search results", + '*', '..' ), + loc( "You can use plugins. Type '%1' to list available plugins", + '/plugins' ), + loc( "You can show all your out of date modules using '%1'", 'o' ), + loc( "Many operations take options, like '%1' or '%2'", + '--verbose', '--skiptest' ), + loc( "The documentation in %1 and %2 is very useful", + "CPANPLUS::Module", "CPANPLUS::Backend" ), + loc( "You can type '%1' for help and '%2' to exit", 'h', 'q' ), + ); + + sub _show_random_tip { + my $self = shift; + print $/, "Did you know...\n ", $tips[ int rand scalar @tips ], $/; + return 1; + } +} + +1; + +__END__ + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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, L, L + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + +__END__ + +TODO: + e => "_expand_inc", # scratch it, imho -- not used enough + +### free letters: g j k n y ### diff --git a/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod b/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod new file mode 100644 index 0000000..c537c4e --- /dev/null +++ b/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod @@ -0,0 +1,136 @@ +=head1 NAME + +CPANPLUS::Shell::Default::Plugins::HOWTO -- documentation on how to write your own plugins + +=head1 SYNOPSIS + + package CPANPLUS::Shell::Default::Plugins::MyPlugin; + + ### return command => method mapping + sub plugins { ( myplugin1 => 'mp1', myplugin2 => 'mp2' ) } + + ### method called when the command '/myplugin1' is issued + sub mp1 { .... } + + ### method called when the command '/? myplugin1' is issued + sub mp1_help { return "Help Text" } + +=head1 DESCRIPTION + +This pod text explains how to write your own plugins for +C. + +=head1 HOWTO + +=head2 Registering Plugin Modules + +Plugins are detected by using C. Every module in +the C namespace is considered a +plugin, and is attempted to be loaded. + +Therefor, any plugin must be declared in that namespace, in a corresponding +C<.pm> file. + +=head2 Registering Plugin Commands + +To register any plugin commands, a list of key value pairs must be returned +by a C method in your package. The keys are the commands you wish +to register, the values are the methods in the plugin package you wish to have +called when the command is issued. + +For example, a simple 'Hello, World!' plugin: + + package CPANPLUS::Shell::Default::Plugins::HW; + + sub plugins { return ( helloworld => 'hw' ) }; + + sub hw { print "Hello, world!\n" } + +When the user in the default shell now issues the C command, +this command will be dispatched to the plugin, and it's C method will +be called + +=head2 Registering Plugin Help + +To provide usage information for your plugin, the user of the default shell +can type C. In that case, the function C +will be called in your plugin package. + +For example, extending the above example, when a user calls C, +the function C will be called, which might look like this: + + sub hw_help { " /helloworld # prints "Hello, world!\n" } + +If you dont provide a corresponding _help function to your commands, the +default shell will handle it gracefully, but the user will be stuck without +usage information on your commands, so it's considered undesirable to omit +the help functions. + +=head2 Arguments to Plugin Commands + +Any plugin function will receive the following arguments when called, which +are all positional: + +=over 4 + +=item Classname -- The name of your plugin class + +=item Shell -- The CPANPLUS::Shell::Default object + +=item Backend -- The CPANPLUS::Backend object + +=item Command -- The command issued by the user + +=item Input -- The input string from the user + +=item Options -- A hashref of options provided by the user + +=back + +For example, the following command: + + /helloworld bob --nofoo --bar=2 joe + +Would yield the following arguments: + + sub hw { + my $class = shift; # CPANPLUS::Shell::Default::Plugins::HW + my $shell = shift; # CPANPLUS::Shell::Default object + my $cb = shift; # CPANPLUS::Backend object + my $cmd = shift; # 'helloworld' + my $input = shift; # 'bob joe' + my $opts = shift; # { foo => 0, bar => 2 } + + .... + } + + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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, L, L + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm b/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm new file mode 100644 index 0000000..c351367 --- /dev/null +++ b/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm @@ -0,0 +1,188 @@ +package CPANPLUS::Shell::Default::Plugins::Remote; + +use strict; + +use Module::Load; +use Params::Check qw[check]; +use CPANPLUS::Error qw[error msg]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +=head1 NAME + +CPANPLUS::Shell::Default::Plugins::Remote + +=head1 SYNOPSIS + + CPAN Terminal> /connect localhost 1337 --user=foo --pass=bar + ... + CPAN Terminal@localhost> /disconnect + +=head1 DESCRIPTION + +This is a C plugin that allows you to connect +to a machine running an instance of C, allowing remote +usage of the C. + +A sample session, updating all modules on a remote machine, might look +like this: + + CPAN Terminal> /connect --user=my_user --pass=secret localhost 1337 + + Connection accepted + + Successfully connected to 'localhost' on port '11337' + + Note that no output will appear until a command has completed + -- this may take a while + + + CPAN Terminal@localhost> o; i * + + [....] + + CPAN Terminal@localhost> /disconnect + + CPAN Terminal> + +=cut + +### store the original prompt here, so we can restore it on disconnect +my $Saved_Prompt; + +sub plugins { ( connect => 'connect', disconnect => 'disconnect' ) } + +sub connect { + my $class = shift; + my $shell = shift; + my $cb = shift; + my $cmd = shift; + my $input = shift || ''; + my $opts = shift || {}; + my $conf = $cb->configure_object; + + my $user; my $pass; + { local $Params::Check::ALLOW_UNKNOWN = 1; + + my $tmpl = { + user => { default => $conf->_get_daemon('username'), + store => \$user }, + pass => { default => $conf->_get_daemon('password'), + store => \$pass }, + }; + + check( $tmpl, $opts ) or return; + } + + my @parts = split /\s+/, $input; + my $host = shift @parts || 'localhost'; + my $port = shift @parts || $conf->_get_daemon('port'); + + load IO::Socket; + + my $remote = IO::Socket::INET->new( + Proto => "tcp", + PeerAddr => $host, + PeerPort => $port, + ) or ( + error( loc( "Cannot connect to port '%1' ". + "on host '%2'", $port, $host ) ), + return + ); + + my $con = { + connection => $remote, + username => $user, + password => $pass, + }; + + ### store the connection + $shell->remote( $con ); + + my($status,$buffer) = $shell->__send_remote_command( + "VERSION=$CPANPLUS::Shell::Default::VERSION"); + + if( $status ) { + print "\n$buffer\n\n"; + + print loc( "Successfully connected to '%1' on port '%2'", + $host, $port ); + print "\n\n"; + print loc( "Note that no output will appear until a command ". + "has completed\n-- this may take a while" ); + print "\n\n"; + + ### save the original prompt + $Saved_Prompt = $shell->prompt; + + $shell->prompt( $shell->brand .'@'. $host .'> ' ); + + } else { + print "\n$buffer\n\n"; + + print loc( "Failed to connect to '%1' on port '%2'", + $host, $port ); + print "\n\n"; + + $shell->remote( undef ); + } +} + +sub disconnect { + my $class = shift; + my $shell = shift; + + print "\n", ( $shell->remote + ? loc( "Disconnecting from remote host" ) + : loc( "Not connected to remote host" ) + ), "\n\n"; + + $shell->remote( undef ); + $shell->prompt( $Saved_Prompt ); +} + +sub connect_help { + return loc( + " /connect [HOST PORT] # Connect to the remote machine,\n" . + " # defaults taken from your config\n" . + " --user=USER # Optional username\n" . + " --pass=PASS # Optional password" ); +} + +sub disconnect_help { + return loc( + " /disconnect # Disconnect from the remote server" ); +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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, L, L + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/lib/CPANPLUS/Shell/Default/Plugins/Source.pm b/lib/CPANPLUS/Shell/Default/Plugins/Source.pm new file mode 100644 index 0000000..889b3d3 --- /dev/null +++ b/lib/CPANPLUS/Shell/Default/Plugins/Source.pm @@ -0,0 +1,107 @@ +package CPANPLUS::Shell::Default::Plugins::Source; + +use strict; +use CPANPLUS::Error qw[error msg]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +=head1 NAME + +CPANPLUS::Shell::Default::Plugins::Source + +=head1 SYNOPSIS + + CPAN Terminal> /source /tmp/list_of_commands /tmp/more_commands + +=head1 DESCRIPTION + +This is a C plugin that works just like +your unix shells source(1) command; it reads in a file that has +commands in it to execute, and then executes them. + +A sample file might look like this: + + # first, update all the source files + x --update_source + + # find all of my modules that are on the CPAN + # test them, and store the error log + a ^KANE$' + t * + p /home/kane/cpan-autotest/log + + # and inform us we're good to go + ! print "Autotest complete, log stored; please enter your commands!" + +Note how empty lines, and lines starting with a '#' are being skipped +in the execution. + +=cut + + +sub plugins { return ( source => 'source' ) } + +sub source { + my $class = shift; + my $shell = shift; + my $cb = shift; + my $cmd = shift; + my $input = shift || ''; + my $opts = shift || {}; + my $verbose = $cb->configure_object->get_conf('verbose'); + + for my $file ( split /\s+/, $input ) { + my $fh = FileHandle->new("$file") or( + error(loc("Could not open file '%1': %2", $file, $!)), + next + ); + + while( my $line = <$fh> ) { + chomp $line; + + next if $line !~ /\S+/; # skip empty/whitespace only lines + next if $line =~ /^#/; # skip comments + + msg(loc("Dispatching '%1'", $line), $verbose); + return 1 if $shell->dispatch_on_input( input => $line ); + } + } +} + +sub source_help { + return loc(' /source FILE [FILE ..] '. + '# read in commands from the specified file' ), +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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, L, L + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/lib/CPANPLUS/bin/cpan2dist b/lib/CPANPLUS/bin/cpan2dist new file mode 100644 index 0000000..2fff756 --- /dev/null +++ b/lib/CPANPLUS/bin/cpan2dist @@ -0,0 +1,597 @@ +#!/usr/bin/perl -w +use strict; +use CPANPLUS::Backend; +use CPANPLUS::Dist; +use CPANPLUS::Internals::Constants; +use Data::Dumper; +use Getopt::Long; +use File::Spec; +use File::Basename; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +use constant PREREQ_SKIP_CLASS => 'CPANPLUS::To::Dist::PREREQ_SKIP'; +use constant ALARM_CLASS => 'CPANPLUS::To::Dist::ALARM'; + +### print when you can +$|++; + +my $cb = CPANPLUS::Backend->new + or die loc("Could not create new CPANPLUS::Backend object"); +my $conf = $cb->configure_object; + +my %formats = map { $_ => $_ } CPANPLUS::Dist->dist_types; + +my $opts = {}; +GetOptions( $opts, + 'format=s', 'archive', + 'verbose!', 'force!', + 'skiptest!', 'keepsource!', + 'makefile!', 'buildprereq!', + 'help', 'flushcache', + 'ban=s@', 'banlist=s@', + 'ignore=s@', 'ignorelist=s@', + 'defaults', 'modulelist=s@', + 'logfile=s', 'timeout=s', + 'dist-opts=s%', + 'default-banlist!', + 'default-ignorelist!', + ); + +die usage() if exists $opts->{'help'}; + +### parse options +my $tarball = $opts->{'archive'} || 0; +my $keep = $opts->{'keepsource'} ? 1 : 0; +my $prereqbuild = exists $opts->{'buildprereq'} + ? $opts->{'buildprereq'} + : 0; +my $timeout = exists $opts->{'timeout'} + ? $opts->{'timeout'} + : 300; + +### use default answers? +$ENV{'PERL_MM_USE_DEFAULT'} = $opts->{'defaults'} ? 1 : 0; + +my $format; +### if provided, we go with the command line option, fall back to conf setting +{ $format = $opts->{'format'} || $conf->get_conf('dist_type'); + $conf->set_conf( dist_type => $format ); + + ### is this a valid format?? + die loc("Invalid format: " . ($format || "[NONE]") ) . usage() + unless $formats{$format}; + + my %map = ( verbose => 'verbose', + force => 'force', + skiptest => 'skiptest', + makefile => 'prefer_makefile' + ); + + ### set config options from arguments + while (my($key,$val) = each %map) { + my $bool = exists $opts->{$key} ? $opts->{$key} : $conf->get_conf($val); + $conf->set_conf( $val => $bool ); + } +} + +my @modules = @ARGV; +if( exists $opts->{'modulelist'} ) { + push @modules, map { parse_file( $_ ) } @{ $opts->{'modulelist'} }; +} + +die usage() unless @modules; + + +my $fh; +LOGFILE: { + if( my $file = $opts->{logfile} ) { + open $fh, ">$file" or ( + warn loc("Could not open '%1' for writing: %2", $file,$!), + last LOGFILE + ); + + warn "Logging to '$file'\n"; + + *STDERR = $fh; + *STDOUT = $fh; + } +} + +### reload indices if so desired +$cb->reload_indices() if $opts->{'flushcache'}; + +{ my @ban = exists $opts->{'ban'} + ? map { qr/$_/ } @{ $opts->{'ban'} } + : (); + + + if( exists $opts->{'banlist'} ) { + push @ban, map { parse_file( $_, 1 ) } @{ $opts->{'banlist'} }; + } + + push @ban, map { s/\s+//; $_ } + map { [split /\s*#\s*/]->[0] } + grep { /#/ } + map { split /\n/ } _default_ban_list() + if $opts->{'default-banlist'}; + + ### use our prereq install callback + $conf->set_conf( prereqs => PREREQ_ASK ); + + ### register install callback ### + $cb->_register_callback( + name => 'install_prerequisite', + code => \&__ask_about_install, + ); + + + ### check for ban patterns when handling prereqs + sub __ask_about_install { + + my $mod = shift or return; + my $prereq = shift or return; + + + ### die with an error object, so we can verify that + ### the die came from this location, and that it's an + ### 'acceptable' death + my $pat = ban_me( $prereq ); + die bless \(loc("Module '%1' requires '%2' to be installed " . + "but found in your ban list (%3) -- skipping", + $mod->module, $prereq->module, $pat )), + PREREQ_SKIP_CLASS if $pat; + return 1; + } + + ### should we skip this module? + sub ban_me { + my $mod = shift; + + for my $pat ( @ban ) { + return $pat if $mod->module =~ /$pat/; + } + return; + } +} + +### patterns to strip from prereq lists +{ my @ignore = exists $opts->{'ignore'} + ? map { qr/$_/ } @{ $opts->{'ignore'} } + : (); + + if( exists $opts->{'ignorelist'} ) { + push @ignore, map { parse_file( $_, 1 ) } @{ $opts->{'ignorelist'} }; + } + + push @ignore, map { s/\s+//; $_ } + map { [split /\s*#\s*/]->[0] } + grep { /#/ } + map { split /\n/ } _default_ignore_list() + if $opts->{'default-ignorelist'}; + + + ### register install callback ### + $cb->_register_callback( + name => 'filter_prereqs', + code => \&__filter_prereqs, + ); + + sub __filter_prereqs { + my $cb = shift; + my $href = shift; + + for my $name ( keys %$href ) { + my $obj = $cb->parse_module( module => $name ) or ( + warn "Cannot make a module object out of ". + "'$name' -- skipping\n", + next ); + + if( my $pat = ignore_me( $obj ) ) { + warn loc("'%1' found in your ignore list (%2) ". + "-- filtering it out\n", $name, $pat); + + delete $href->{ $name }; + } + } + + return $href; + } + + ### should we skip this module? + sub ignore_me { + my $mod = shift; + + for my $pat ( @ignore ) { + return $pat if $mod->module =~ /$pat/; + return $pat if $mod->package_name =~ /$pat/; + } + return; + } +} + + +my %done; +for my $name (@modules) { + + my $obj; + + ### is it a tarball? then we get it locally and transform it + ### and it's dependencies into .debs + if( $tarball ) { + ### make sure we use an absolute path, so chdirs() dont + ### mess things up + $name = File::Spec->rel2abs( $name ); + + ### ENOTARBALL? + unless( -e $name ) { + warn loc("Archive '$name' does not exist"); + next; + } + + $obj = CPANPLUS::Module::Fake->new( + module => basename($name), + path => dirname($name), + package => basename($name), + ); + + ### if it's a traditional CPAN package, we can tidy + ### up the module name some + $obj->module( $obj->package_name ) if $obj->package_name; + + ### get the version from the package name + $obj->version( $obj->package_version || 0 ); + + ### set the location of the tarball + $obj->status->fetch($name); + + ### plain old cpan module? + } else { + + ### find the corresponding module object ### + $obj = $cb->parse_module( module => $name ) or ( + warn "Cannot make a module object out of ". + "'$name' -- skipping\n", + next ); + } + + ### you banned it? + if( my $pat = ban_me( $obj ) ) { + warn loc("'%1' found in your ban list (%2) -- skipping\n", + $obj->module, $pat ); + next; + } + + ### or just ignored it? + if( my $pat = ignore_me( $obj ) ) { + warn loc("'%1' found in your ignore list (%2) -- skipping\n", + $obj->module, $pat ); + next; + } + + + my $dist = eval { + local $SIG{ALRM} = sub { die bless {}, ALARM_CLASS } + if $timeout; + + alarm $timeout || 0; + + my $dist_opts = $opts->{'dist-opts'} || {}; + + my $rv = $obj->install( + prereq_target => 'create', + target => 'create', + keep_source => $keep, + prereq_build => $prereqbuild, + + ### any passed arbitrary options + %$dist_opts, + ); + + alarm 0; + + $rv; + }; + + ### set here again, in case the install dies + alarm 0; + + ### install failed due to a 'die' in our prereq skipper? + if( $@ and ref $@ and $@->isa( PREREQ_SKIP_CLASS ) ) { + warn loc("Dist creation of '%1' skipped: '%2'", + $obj->module, ${$@} ); + next; + + } elsif ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) { + warn loc("\nDist creation of '%1' skipped, build time exceeded: ". + "%2 seconds\n", $obj->module, $timeout ); + next; + + ### died for some other reason? just report and skip + } elsif ( $@ ) { + warn loc("Dist creation of '%1' failed: '%2'", + $obj->module, $@ ); + next; + } + + ### we didn't get a dist object back? + unless ($dist and $obj->status->dist) { + warn loc("Unable to create '%1' dist of '%2'", $format, $obj->module); + next + } + + print "Created '$format' distribution for ", $obj->module, + " to:\n\t", $obj->status->dist->status->dist, "\n"; +} + + +sub parse_file { + my $file = shift or return; + my $qr = shift() ? 1 : 0; + + my $fh = OPEN_FILE->( $file ) or return; + + my @rv; + while( <$fh> ) { + chomp; + next if /^#/; # skip comments + next unless /\S/; # skip empty lines + s/^(\S+).*/$1/; # skip extra info + push @rv, $qr ? qr/$_/ : $_; # add pattern to the list + } + + return @rv; +} + +=head1 NAME + +cpan2dist - The CPANPLUS distribution creator + +=head1 DESCRIPTION + +This script will create distributions of C modules of the format +you specify, including its prerequisites. These packages can then be +installed using the corresponding package manager for the format. + +Note, you can also do this interactively from the default shell, +C. See the C documentation, +as well as the documentation of your format of choice for any format +specific documentation. + +=head1 USAGE + +=cut + +sub usage { + my $me = basename($0); + my $formats = join "\n", map { "\t\t$_" } sort keys %formats; + + my $usage = << '=cut'; +=pod + + Usage: cpan2dist [--format FMT] [OPTS] Mod::Name [Mod::Name, ...] + cpan2dist [--format FMT] [OPTS] --modulelist /tmp/mods.list + cpan2dist [--format FMT] [OPTS] --archive /tmp/dist [/tmp/dist2] + + Will create a distribution of type FMT of the modules + specified on the command line, and all their prerequisites. + + Can also create a distribution of type FMT from a local + archive and all it's prerequisites + +=cut + + $usage .= qq[ + Possible formats are: +$formats + + You can install more formats from CPAN! + \n]; + + $usage .= << '=cut'; +=pod + +Options: + + ### take no argument: + --help Show this help message + --skiptest Skip tests. Can be negated using --noskiptest + --force Force operation. Can be negated using --noforce + --verbose Be verbose. Can be negated using --noverbose + --keepsource Keep sources after building distribution. Can be + negated by --nokeepsource. May not be supported + by all formats + --makefile Prefer Makefile.PL over Build.PL. Can be negated + using --nomakefile. Defaults to your config setting + --buildprereq Build packages of any prerequisites, even if they are + already uptodate on the local system. Can be negated + using --nobuildprereq. Defaults to false. + --archive Indicate that all modules listed are actually archives + --flushcache Update CPANPLUS' cache before commencing any operation + --defaults Instruct ExtUtils::MakeMaker and Module::Build to use + default answers during 'perl Makefile.PL' or 'perl + Build.PL' calls where possible + + ### take argument: + --format Installer format to use (defaults to config setting) + --ban Patterns of module names to skip during installation + (affects prerequisites too) May be given multiple times + --banlist File containing patterns that could be given to --ban + Are appended to the ban list built up by --ban + May be given multiple times. + --ignore Patterns of modules to exclude from prereq list. Useful + for when a prereq listed by a CPAN module is resolved + in another way than from its corresponding CPAN package + (Match is done on both module name, and package name of + the package the module is in) + --ignorelist File containing patterns that may be given to --ignore. + Are appended to the ban list build up by --ignore. + May be given multiple times. + --modulelist File containing a list of modules that should be built. + Are appended to the list of command line modules. + May be given multiple times. + --logfile File to log all output to. By default, all output goes + to the console. + --timeout The allowed time for buliding a distribution before + aborting. This is useful to terminate any build that + hang or happen to be interactive despite being told not + to be. Defaults to 300 seconds. To turn off, you can + set it to 0. + --dist-opts Arbitrary options passed along to the chosen installer + format's prepare()/create() routine. + + ### builtin lists + --default-banlist Use our builtin banlist. Works just like --ban + and --banlist, but with pre-set lists. See the + "Builtin Lists" section for details. + --default-ignorelist Use our builtin ignorelist. Works just like + --ignore and --ignorelist but with pre-set lists. + See the "Builtin Lists" section for details. + +Examples: + + ### build a debian package of DBI and it's prerequisites, + ### don't bother running tests + cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --skiptest DBI + + ### Build a package, whose format is determined by your config of + ### the local tarball, reloading cpanplus' indices first and using + ### the tarballs Makefile.PL if it has one. + cpan2dist --makefile --flushcache --archive /path/to/Cwd-1.0.tgz + + ### build a package from Net::FTP, but dont build any packages or + ### dependencies whose name match 'Foo', 'Bar' or any of the + ### patterns mentioned in /tmp/ban + cpan2dist --ban Foo --ban Bar --banlist /tmp/ban Net::FTP + + ### build a package from Net::FTP, but ignore it's listed dependency + ### on IO::Socket, as it's shipped per default with the OS we're on + cpan2dist --ignore IO::Socket Net::FTP + + ### building all modules listed, plus their prerequisites + cpan2dist --ignorelist /tmp/modules.ignore --banlist /tmp/modules.ban + --modulelist /tmp/modules.list --buildprereq --flushcache + --makefile --defaults + + ### pass arbitrary options to the format's prepare()/create() routine + cpan2dist --dist-opts deb_version=3 --dist-opts prefix=corp + +=cut + + $usage .= qq[ +Builtin Lists: + + Ignore list:] . _default_ignore_list() . qq[ + Ban list:] . _default_ban_list(); + + ### strip the pod directives + $usage =~ s/=pod\n//g; + + return $usage; +} + +=pod + +=head1 Built-In Filter Lists + +Some modules you'd rather not package. Some because they +are part of core-perl and you dont want a new package. +Some because they won't build on your system. Some because +your package manager of choice already packages them for you. + +There may be a myriad of reasons. You can use the C<--ignore> +and C<--ban> options for this, but we provide some built-in +lists that catch common cases. You can use these built-in lists +if you like, or supply your own if need be. + +=head2 Built-In Ignore List + +=pod + +You can use this list of regexes to ignore modules matching +to be listed as prerequisites of a package. Particulaly useful +if they are bundled with core-perl anyway and they have known +issues building. + +Toggle it by supplying the C<--default-ignorelist> option. + +=cut + +sub _default_ignore_list { + + my $list = << '=cut'; +=pod + + ^IO$ # Provided with core anyway + ^Cwd$ # Provided with core anyway + ^File::Spec # Provided with core anyway + ^Config$ # Perl's own config, not shipped separately + ^ExtUtils::MakeMaker$ # Shipped with perl, recent versions + # have bug 14721 (see rt.cpan.org) + ^ExtUtils::Install$ # Part of of EU::MM, same reason + +=cut + + return $list; +} + +=head2 Built-In Ban list + +You can use this list of regexes to disable building of these +modules altogether. + +Toggle it by supplying the C<--default-banlist> option. + +=cut + +sub _default_ban_list { + + my $list = << '=cut'; +=pod + + ^GD$ # Needs c libaries + ^Berk.*DB # DB packages require specific options & linking + ^DBD:: # DBD drives require database files/headers + ^XML:: # XML modules usually require expat libraries + Apache # These usually require apache libraries + SSL # These usually require SSL certificates & libs + Image::Magick # Needs ImageMagick C libraries + Mail::ClamAV # Needs ClamAV C Libraries + ^Verilog # Needs Verilog C Libraries + ^Authen::PAM$ # Needs PAM C libraries & Headers + +=cut + + return $list; +} + +__END__ + +=head1 SEE ALSO + +L, L, L, +C + +=head1 BUG REPORTS + +Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. + +=head1 AUTHOR + +This module by Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans Ekane@cpan.orgE. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/bin/cpanp b/lib/CPANPLUS/bin/cpanp new file mode 100644 index 0000000..b1a8f9e --- /dev/null +++ b/lib/CPANPLUS/bin/cpanp @@ -0,0 +1,103 @@ +#!/usr/bin/perl +# $File: //depot/cpanplus/dist/bin/cpanp $ +# $Revision: #8 $ $Change: 8345 $ $DateTime: 2003/10/05 19:25:48 $ + +use strict; +use vars '$VERSION'; + +use CPANPLUS; +$VERSION = CPANPLUS->VERSION; + +use CPANPLUS::Shell qw[Default]; +my $shell = CPANPLUS::Shell->new; + +### if we're given a command, run it; otherwise, open a shell. +if (@ARGV) { + ### take the command line arguments as a command + my $input = "@ARGV"; + ### if they said "--help", fix it up to work. + $input = 'h' if $input =~ /^\s*--?h(?:elp)?\s*$/i; + ### strip the leading dash + $input =~ s/^\s*-//; + ### pass the command line to the shell + $shell->dispatch_on_input(input => $input, noninteractive => 1); +} else { + ### open a shell for the user + $shell->shell(); +} + +=head1 NAME + +cpanp - The CPANPLUS launcher + +=head1 SYNOPSIS + +B + +B S<[-]B> S<[ --[B-]I