diff options
| author | Rafael Garcia-Suarez <rgarciasuarez@gmail.com> | 2007-04-10 07:42:33 +0000 |
|---|---|---|
| committer | Rafael Garcia-Suarez <rgarciasuarez@gmail.com> | 2007-04-10 07:42:33 +0000 |
| commit | 6aaee015312976007994b80b72c65ab6b6237774 (patch) | |
| tree | da8e722757077a1fda3796b78f5db4bee5643249 | |
| parent | 8aefeee2c641e088fc7ae56870f0748e4f607f90 (diff) | |
| download | perl-6aaee015312976007994b80b72c65ab6b6237774.tar.gz | |
Add CPANPLUS 0.78
p4raw-id: //depot/perl@30883
97 files changed, 22250 insertions, 7 deletions
@@ -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 0123e53666..f4742ee35a 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 0000000000..b30aa7f0ee --- /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<CPANPLUS> library is an API to the C<CPAN> 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<CPANPLUS> API is meant to let you programmatically +interact with the C<CPAN> mirrors. The documentation in +L<CPANPLUS::Backend> shows you how to create an object +capable of interacting with those mirrors, letting you +create & retrieve module objects. +L<CPANPLUS::Module> shows you how you can use these module +objects to perform actions like installing and testing. + +The default shell, documented in L<CPANPLUS::Shell::Default> +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<cpanp -h> or L<CPANPLUS::Shell::Default> +for instructions on using the default shell. + +=head2 CHOOSE A SHELL + +By running C<cpanp> without arguments, you will start up +the shell specified in your config, which defaults to +L<CPANPLUS::Shell::Default>. There are more shells available. +C<CPANPLUS> itself ships with an emulation shell called +L<CPANPLUS::Shell::Classic> that looks and feels just like +the old C<CPAN.pm> shell. + +You can start this shell by typing: + + $ perl -MCPANPLUS -e'shell Classic' + +Even more shells may be available from C<CPAN>. + +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<cpan2dist> is a commandline tool to convert any distribution +from C<CPAN> into a package in the format of your choice, like +for example C<.deb> or C<FreeBSD ports>. + +See C<cpan2dist -h> for details. + + +=head1 FUNCTIONS + +For quick access to common commands, you may use this module, +C<CPANPLUS> rather than the full programmatic API situated in +C<CPANPLUS::Backend>. 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<cpanp> command, which will be installed in your +perl bin. + +=head1 FAQ + +For frequently asked questions and answers, please consult the +C<CPANPLUS::FAQ> manual. + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Default>, L<CPANPLUS::FAQ>, L<CPANPLUS::Backend>, L<CPANPLUS::Module>, L<cpanp>, L<cpan2dist> + +=head1 CONTACT INFORMATION + +=over 4 + +=item * Bug reporting: +I<bug-cpanplus@rt.cpan.org> + +=item * Questions & suggestions: +I<cpanplus-devel@lists.sourceforge.net> + +=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 0000000000..50b13c4628 --- /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<CPANPLUS> +libraries. + +=head1 ENVIRONMENT + +When C<CPANPLUS::Backend> is loaded, which is necessary for just +about every <CPANPLUS> operation, the environment variable +C<PERL5_CPANPLUS_IS_RUNNING> is set to the current process id. + +Additionally, the environment variable C<PERL5_CPANPLUS_IS_VERSION> +will be set to the version of C<CPANPLUS::Backend>. + +This information might be useful somehow to spawned processes. + +=head1 METHODS + +=head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] ) + +This method returns a new C<CPANPLUS::Backend> object. +This also initialises the config corresponding to this object. +You have two choices in this: + +=over 4 + +=item Provide a valid C<CPANPLUS::Configure> object + +This will be used verbatim. + +=item No arguments + +Your default config will be loaded and used. + +=back + +New will return a C<CPANPLUS::Backend> object on success and die on +failure. + +=cut + +sub new { + my $class = shift; + my $conf; + + if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) { + $conf = shift; + } else { + $conf = CPANPLUS::Configure->new() or return; + } + + my $self = $class->SUPER::_init( _conf => $conf ); + + return $self; +} + +=pod + +=head2 $href = $cb->module_tree( [@modules_names_list] ) + +Returns a reference to the CPANPLUS module tree. + +If you give it any arguments, they will be treated as module names +and C<module_tree> will try to look up these module names and +return the corresponding module objects instead. + +See L<CPANPLUS::Module> for the operations you can perform on a +module object. + +=cut + +sub module_tree { + my $self = shift; + my $modtree = $self->_module_tree; + + if( @_ ) { + my @rv; + for my $name ( grep { defined } @_) { + 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<author_tree> will try to look up these author names and +return the corresponding author objects instead. + +See L<CPANPLUS::Module::Author> for the operations you can perform on +an author object. + +=cut + +sub author_tree { + my $self = shift; + my $authtree = $self->_author_tree; + + if( @_ ) { + my @rv; + for my $name (@_) { + push @rv, $authtree->{$name} || ''; + } + return @rv == 1 ? $rv[0] : @rv; + } else { + return $authtree; + } +} + +=pod + +=head2 $conf = $cb->configure_object () + +Returns a copy of the C<CPANPLUS::Configure> object. + +See L<CPANPLUS::Configure> for operations you can perform on a +configure object. + +=cut + +sub configure_object { return shift->_conf() }; + +=head2 $su = $cb->selfupdate_object; + +Returns a copy of the C<CPANPLUS::Selfupdate> object. + +See the L<CPANPLUS::Selfupdate> manpage for the operations +you can perform on the selfupdate object. + +=cut + +sub selfupdate_object { return shift->_selfupdate() }; + +=pod + +=head2 @mods = $cb->search( type => TYPE, allow => AREF, [data => AREF, verbose => BOOL] ) + +C<search> enables you to search for either module or author objects, +based on their data. The C<type> you can specify is any of the +accessors specified in C<CPANPLUS::Module::Author> or +C<CPANPLUS::Module>. C<search> will determine by the C<type> you +specified whether to search by author object or module object. + +You have to specify an array reference of regular expressions or +strings to match against. The rules used for this array ref are the +same as in C<Params::Check>, so read that manpage for details. + +The search is an C<or> search, meaning that if C<any> of the criteria +match, the search is considered to be successful. + +You can specify the result of a previous search as C<data> to limit +the new search to these module or author objects, rather than the +entire module or author tree. This is how you do C<and> searches. + +Returns a list of module or author objects on success and false +on failure. + +See L<CPANPLUS::Module> for the operations you can perform on a +module object. +See L<CPANPLUS::Module::Author> for the operations you can perform on +an author object. + +=cut + +sub search { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + 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<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=head2 $backend_rv = $cb->extract( modules => \@mods ) + +Extracts a list of modules. C<@mods> can be a list of distribution +names, module names or module objects--basically anything that +L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=head2 $backend_rv = $cb->install( modules => \@mods ) + +Installs a list of modules. C<@mods> can be a list of distribution +names, module names or module objects--basically anything that +L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=head2 $backend_rv = $cb->readme( modules => \@mods ) + +Fetches the readme for a list of modules. C<@mods> can be a list of +distribution names, module names or module objects--basically +anything that L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=head2 $backend_rv = $cb->files( modules => \@mods ) + +Returns a list of files used by these modules if they are installed. +C<@mods> can be a list of distribution names, module names or module +objects--basically anything that L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=head2 $backend_rv = $cb->distributions( modules => \@mods ) + +Returns a list of module objects representing all releases for this +module on success. +C<@mods> can be a list of distribution names, module names or module +objects, basically anything that L<parse_module> can understand. + +See the equivalent method in C<CPANPLUS::Module> for details on +other options you can pass. + +Since this is a multi-module method call, the return value is +implemented as a C<CPANPLUS::Backend::RV> object. Please consult +that module's documentation on how to interpret the return value. + +=cut + +### XXX add direcotry_tree, packlist etc? or maybe remove files? ### +for my $func (qw[fetch extract install readme files distributions]) { + no strict 'refs'; + + *$func = sub { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + 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<parse_module> tries to find a C<CPANPLUS::Module> object that +matches your query. Here's a list of examples you could give to +C<parse_module>; + +=over 4 + +=item Text::Bastardize + +=item Text-Bastardize + +=item Text-Bastardize-1.06 + +=item AYRNIEU/Text-Bastardize + +=item AYRNIEU/Text-Bastardize-1.06 + +=item AYRNIEU/Text-Bastardize-1.06.tar.gz + +=item http://example.com/Text-Bastardize-1.06.tar.gz + +=item file:///tmp/Text-Bastardize-1.06.tar.gz + +=back + +These items would all come up with a C<CPANPLUS::Module> object for +C<Text::Bastardize>. The ones marked explicitly as being version 1.06 +would give back a C<CPANPLUS::Module> object of that version. +Even if the version on CPAN is currently higher. + +If C<parse_module> is unable to actually find the module you are looking +for in its module tree, but you supplied it with an author, module +and version part in a distribution name or URI, it will create a fake +C<CPANPLUS::Module> object for you, that you can use just like the +real thing. + +See L<CPANPLUS::Module> for the operations you can perform on a +module object. + +If even this fancy guessing doesn't enable C<parse_module> to create +a fake module object for you to use, it will warn about an error and +return false. + +=cut + +sub parse_module { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $mod; + my $tmpl = { + module => { required => 1, store => \$mod }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + return $mod if IS_MODOBJ->( module => $mod ); + + ### ok, so it's not a module object, but a ref nonetheless? + ### what are you smoking? + if( ref $mod ) { + error(loc("Can not parse module string from reference '%1'", $mod )); + return; + } + + ### check only for allowed characters in a module name + unless( $mod =~ /[^\w:]/ ) { + + ### perhaps we can find it in the module tree? + my $maybe = $self->module_tree($mod); + return $maybe if IS_MODOBJ->( module => $maybe ); + } + + ### 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<update_source> is set to true, this will fetch new source files +from your CPAN mirror. Otherwise, C<reload_indices> will do its +usual cache checking and only update them if they are out of date. + +By default, C<update_source> will be false. + +The verbose setting defaults to what you have specified in your +config file. + +Returns true on success and false on failure. + +=cut + +sub reload_indices { + my $self = shift; + my %hash = @_; + my $conf = $self->configure_object; + + my $tmpl = { + update_source => { default => 0, allow => [qr/^\d$/] }, + verbose => { default => $conf->get_conf('verbose') }, + }; + + my $args = check( $tmpl, \%hash ) or return; + + ### make a call to the internal _module_tree, so it triggers cache + ### file age + my $uptodate = $self->_check_trees( %$args ); + + + return 1 if $self->_build_trees( + uptodate => $uptodate, + use_stored => 0, + verbose => $conf->get_conf('verbose'), + ); + + error( loc( "Error rebuilding source trees!" ) ); + + return; +} + +=pod + +=head2 $bool = $cb->flush(CACHE_NAME) + +This method allows flushing of caches. +There are several things which can be flushed: + +=over 4 + +=item * C<methods> + +The return status of methods which have been attempted, such as +different ways of fetching files. It is recommended that automatic +flushing be used instead. + +=item * C<hosts> + +The return status of URIs which have been attempted, such as +different hosts of fetching files. It is recommended that automatic +flushing be used instead. + +=item * C<modules> + +Information about modules such as prerequisites and whether +installation succeeded, failed, or was not attempted. + +=item * C<lib> + +This resets PERL5LIB, which is changed to ensure that while installing +modules they are in our @INC. + +=item * C<load> + +This resets the cache of modules we've attempted to load, but failed. +This enables you to load them again after a failed load, if they +somehow have become available. + +=item * C<all> + +Flush all of the aforementioned caches. + +=back + +Returns true on success and false on failure. + +=cut + +sub flush { + my $self = shift; + my $type = shift or return; + + my $cache = { + methods => [ qw( methods load ) ], + hosts => [ qw( hosts ) ], + modules => [ qw( modules lib) ], + lib => [ qw( lib ) ], + load => [ qw( load ) ], + all => [ qw( hosts lib modules methods load ) ], + }; + + my $aref = $cache->{$type} + or ( + error( loc("No such cache '%1'", $type) ), + return + ); + + return $self->_flush( list => $aref ); +} + +=pod + +=head2 @mods = $cb->installed() + +Returns a list of module objects of all your installed modules. +If an error occurs, it will return false. + +See L<CPANPLUS::Module> for the operations you can perform on a +module object. + +=cut + +sub installed { + my $self = shift; + my $aref = $self->_all_installed; + + return @$aref if $aref; + return; +} + +=pod + +=head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] ) + +Creates a local mirror of CPAN, of only the most recent sources in a +location you specify. If you set this location equal to a custom host +in your C<CPANPLUS::Config> you can use your local mirror to install +from. + +It takes the following arguments: + +=over 4 + +=item path + +The location where to create the local mirror. + +=item index_files + +Enable/disable fetching of index files. 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<CPANPLUS::Config>. + +=item verbose + +Prints more messages about what its doing. + +Defaults to whatever setting you have in your C<CPANPLUS::Config>. + +=back + +Returns true on success and false on error. + +=cut + +sub local_mirror { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path, $index, $force, $verbose); + my $tmpl = { + path => { default => $conf->get_conf('base'), + store => \$path }, + index_files => { default => 1, store => \$index }, + force => { default => $conf->get_conf('force'), + store => \$force }, + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return; + + unless( -d $path ) { + $self->_mkdir( dir => $path ) + or( error( loc( "Could not create '%1', giving up", $path ) ), + return + ); + } elsif ( ! -w _ ) { + error( loc( "Could not write to '%1', giving up", $path ) ); + return; + } + + my $flag; + AUTHOR: { + for my $auth ( sort { $a->cpanid cmp $b->cpanid } + values %{$self->author_tree} + ) { + + MODULE: { + my $i; + for my $mod ( $auth->modules ) { + my $fetchdir = File::Spec->catdir( $path, $mod->path ); + + my %opts = ( + verbose => $verbose, + force => $force, + fetchdir => $fetchdir, + ); + + ### only do this the for the first module ### + unless( $i++ ) { + $mod->_get_checksums_file( + %opts + ) or ( + error( loc( "Could not fetch %1 file, " . + "skipping author '%2'", + CHECKSUMS, $auth->cpanid ) ), + $flag++, next AUTHOR + ); + } + + $mod->fetch( %opts ) + or( error( loc( "Could not fetch '%1'", $mod->module ) ), + $flag++, next MODULE + ); + } } + } } + + if( $index ) { + for my $name (qw[auth dslip mod]) { + $self->_update_source( + name => $name, + verbose => $verbose, + path => $path, + ) or ( $flag++, next ); + } + } + + return !$flag; +} + +=pod + +=head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL]) + +Writes out a snapshot of your current installation in C<CPAN> bundle +style. This can then be used to install the same modules for a +different or on a different machine. + +It will, by default, write to an 'autobundle' directory under your +cpanplus homedirectory, but you can override that by supplying a +C<path> argument. + +It will return the location of the output file on success and false on +failure. + +=cut + +sub autobundle { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($path,$force,$verbose); + my $tmpl = { + force => { default => $conf->get_conf('force'), store => \$force }, + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + path => { default => File::Spec->catdir( + $conf->get_conf('base'), + $self->_perl_version( perl => $^X ), + $conf->_get_build('distdir'), + $conf->_get_build('autobundle') ), + store => \$path }, + }; + + check($tmpl, \%hash) or return; + + unless( -d $path ) { + $self->_mkdir( dir => $path ) + or( error(loc("Could not create directory '%1'", $path ) ), + return + ); + } + + my $name; my $file; + { ### default filename for the bundle ### + my($year,$month,$day) = (localtime)[5,4,3]; + $year += 1900; $month++; + + my $ext = 0; + + my $prefix = $conf->_get_build('autobundle_prefix'); + my $format = "${prefix}_%04d_%02d_%02d_%02d"; + + BLOCK: { + $name = sprintf( $format, $year, $month, $day, $ext); + + $file = File::Spec->catfile( $path, $name . '.pm' ); + + -f $file ? ++$ext && redo BLOCK : last BLOCK; + } + } + my $fh; + unless( $fh = FileHandle->new( ">$file" ) ) { + error( loc( "Could not open '%1' for writing: %2", $file, $! ) ); + return; + } + + my $string = join "\n\n", + map { + join ' ', + $_->module, + ($_->installed_version(verbose => 0) || 'undef') + } sort { + $a->module cmp $b->module + } $self->installed; + + my $now = scalar localtime; + my $head = '=head1'; + my $pkg = __PACKAGE__; + my $version = $self->VERSION; + my $perl_v = join '', `$^X -V`; + + print $fh <<EOF; +package $name + +\$VERSION = '0.01'; + +1; + +__END__ + +$head NAME + +$name - Snapshot of your installation at $now + +$head SYNOPSIS + +perl -MCPANPLUS -e "install $name" + +$head CONTENTS + +$string + +$head CONFIGURATION + +$perl_v + +$head AUTHOR + +This bundle has been generated autotomatically by + $pkg $version + +EOF + + close $fh; + + return $file; +} + +1; + +=pod + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author> + +=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 0000000000..9edbe0452c --- /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<ok> 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<new()> will try to deduce the name +from C<caller()> 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 E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +1; diff --git a/lib/CPANPLUS/Config.pm b/lib/CPANPLUS/Config.pm new file mode 100644 index 0000000000..2516559f78 --- /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 0000000000..51d74ef4db --- /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<CPANPLUS::Backend> documentation on how to +obtain a C<CPANPLUS::Configure> 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<new> method, but instead retrieve the desired object via +a method call on a C<CPANPLUS::Backend> object. + +The C<load_configs> parameter controls wether or not additional +user configurations are to be loaded or not. Defaults to C<true>. + +=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<new()> to load user/system configurations + +If the C<rescan> option is provided, your disk will be +examined again to see if there are new config files that +could be read. Defaults to C<false>. + +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<CPANPLUS::Config::System>, 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<conf> of C<program>) 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<get_*> style accessors merely retrieves one or more desired +config options. + +=head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] ); + +The C<set_*> 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<add_*> 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<cpanpd>, 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 E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup> + +=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 0000000000..81ee2cadfe --- /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 0000000000..50acb48bc4 --- /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<CPANPLUS::Dist> is a base class for any type of C<CPANPLUS::Dist::> +modules. + +=head1 ACCESSORS + +=over 4 + +=item parent() + +Returns the C<CPANPLUS::Module> object that parented this object. + +=item status() + +Returns the C<Object::Accessor> 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<undef> may be +interpreted as C<not yet attempted>. + +=item installed() + +Boolean indicating whether the dist was installed successfully. +Explicitly set to C<0> when failed, so a value of C<undef> may be +interpreted as C<not yet attempted>. + +=item uninstalled() + +Boolean indicating whether the dist was uninstalled successfully. +Explicitly set to C<0> when failed, so a value of C<undef> may be +interpreted as C<not yet attempted>. + +=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<CPANPLUS::Dist> object based on the provided C<MODOBJ>. +The optional argument C<format> is used to indicate what type of dist +you would like to create (like C<makemaker> for a C<CPANPLUS::Dist::MM> +object, C<build> for a C<CPANPLUS::Dist::Build> object, and so on ). +If not provided, will default to the setting as specified by your +config C<dist_type>. + +Returns a C<CPANPLUS::Dist> 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 0000000000..2ba0abb64b --- /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<CPANPLUS::Dist::Base> 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<prepare> 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<status> +object, which you might do as follows: + + $dist->status->mk_accessors( qw[my_implementation_accessor] ); + +The C<status> object is implemented as an instance of the +C<Object::Accessor> class. Please refer to it's documentation for +details. + +Return true if the initialization was successul, and false if it was +not. + +The C<CPANPLUS::Dist::Base> 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<create> step can create the actual +distribution(file). +A C<prepare> call in the standard C<ExtUtils::MakeMaker> distribution +would, for example, run C<perl Makefile.PL> to find the dependencies +for a distribution. For a C<debian> distribution, this is where you +would write all the metafiles required for the C<dpkg-*> tools. + +The C<CPANPLUS::Dist::Base> implementation simply calls the underlying +distribution class (Typically C<CPANPLUS::Dist::MM> or +C<CPANPLUS::Dist::Build>). + +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<prepare> call, that set up your environment so +the C<create> step can create the actual distribution(file). +A C<create> call in the standard C<ExtUtils::MakeMaker> distribution +would, for example, run C<make> and C<make test> to build and test +a distribution. For a C<debian> distribution, this is where you +would create the actual C<.deb> file using C<dpkg>. + +The C<CPANPLUS::Dist::Base> implementation simply calls the underlying +distribution class (Typically C<CPANPLUS::Dist::MM> or +C<CPANPLUS::Dist::Build>). + +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<create> call, which prepared a distribution(file) +to install. +A C<create> call in the standard C<ExtUtils::MakeMaker> distribution +would, for example, run C<make install> to copy the distribution files +to their final destination. For a C<debian> distribution, this is where +you would run C<dpkg --install> on the created C<.deb> file. + +The C<CPANPLUS::Dist::Base> implementation simply calls the underlying +distribution class (Typically C<CPANPLUS::Dist::MM> or +C<CPANPLUS::Dist::Build>). + +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<uninstall> call in the standard C<ExtUtils::MakeMaker> distribution +would, for example, run C<make uninstall> to remove the distribution +files the file system. For a C<debian> distribution, this is where you +would run C<dpkg --uninstall PACKAGE>. + +The C<CPANPLUS::Dist::Base> implementation simply calls the underlying +distribution class (Typically C<CPANPLUS::Dist::MM> or +C<CPANPLUS::Dist::Build>). + +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 0000000000..f61cfc822e --- /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<CPANPLUS::Dist::MM> is a distribution class for MakeMaker related +modules. +Using this package, you can create, install and uninstall perl +modules. It inherits from C<CPANPLUS::Dist>. + +=head1 ACCESSORS + +=over 4 + +=item parent() + +Returns the C<CPANPLUS::Module> object that parented this object. + +=item status() + +Returns the C<Object::Accessor> 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<make> (or C<Build>) command was successful. + +=item test () + +BOOL indicating if the C<make test> (or C<Build test>) command was +successful. + +=item prepared () + +BOOL indicating if the C<prepare> call exited succesfully +This gets set after C<perl Makefile.PL> + +=item distdir () + +Full path to the directory in which the C<prepare> call took place, +set after a call to C<prepare>. + +=item created () + +BOOL indicating if the C<create> call exited succesfully. This gets +set after C<make> and C<make test>. + +=item installed () + +BOOL indicating if the module was installed. This gets set after +C<make install> (or C<Build install>) exits successfully. + +=item uninstalled () + +BOOL indicating if the module was uninstalled properly. + +=item _create_args () + +Storage of the arguments passed to C<create> for this object. Used +for recursive calls when satisfying prerequisites. + +=item _install_args () + +Storage of the arguments passed to C<install> 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<CPANPLUS::Dist::MM> object for use. +Effectively creates all the needed status accessors. + +Called automatically whenever you create a new C<CPANPLUS::Dist> 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<prepare> preps a distribution for installation. This means it will +run C<perl Makefile.PL> and determine what prerequisites this distribution +declared. + +If you set C<force> to true, it will go over all the stages of the +C<prepare> process again, ignoring any previously cached results. + +When running C<perl Makefile.PL>, the environment variable +C<PERL5_CPANPLUS_IS_EXECUTING> will be set to the full path of the +C<Makefile.PL> that is being executed. This enables any code inside +the C<Makefile.PL> 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<Makefile> for C<PREREQ_PM> entries and distills from that +any prerequisites mentioned in the C<Makefile> + +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<create> creates the files necessary for installation. This means +it will run C<make> and C<make test>. This will also scan for and +attempt to satisfy any prerequisites the module may have. + +If you set C<skiptest> to true, it will skip the C<make test> stage. +If you set C<force> to true, it will go over all the stages of the +C<make> process again, ignoring any previously cached results. It +will also ignore a bad return value from C<make test> 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; + } + } + } + } #</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<install> 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<Makefile.PL> from the information in a +module object. It is used to write a C<Makefile.PL> 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 0000000000..0b0939208f --- /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<Obsolete>. Please read the documentation and code +in C<CPANPLUS::Dist::Base>. + +=cut + +1; diff --git a/lib/CPANPLUS/Error.pm b/lib/CPANPLUS/Error.pm new file mode 100644 index 0000000000..38710a8a85 --- /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<STDOUT> (or actually +C<$MSG_FH>, see the C<GLOBAL VARIABLES> section below), if the +C<VERBOSE> option is true. +The C<VERBOSE> option defaults to false. + +=head2 msg() + +An alias for C<cp_msg>. + +=head2 cp_error("error string" [,VERBOSE]) + +Records an error on the stack, and prints it to C<STDERR> (or actually +C<$ERROR_FH>, see the C<GLOBAL VARIABLES> sections below), if the +C<VERBOSE> option is true. +The C<VERBOSE> options defaults to true. + +=head2 error() + +An alias for C<cp_error>. + +=head1 CLASS METHODS + +=head2 CPANPLUS::Error->stack() + +Retrieves all the items on the stack. Since C<CPANPLUS::Error> is +implemented using C<Log::Message>, consult its manpage for the +function C<retrieve> 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<TRACE> option is +true all items are returned with C<Carp::longmess> output, rather than +just the message. +C<TRACE> defaults to false. + +=head2 CPANPLUS::Error->flush() + +Removes all the items from the stack and returns them. Since +C<CPANPLUS::Error> is implemented using C<Log::Message>, consult its +manpage for the function C<retrieve> 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<error()> are being +printed. This defaults to C<*STDERR>. + +=item $MSG_FH + +This is the filehandle all the messages sent to C<msg()> 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 0000000000..82bb57aaf4 --- /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 E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + diff --git a/lib/CPANPLUS/Hacking.pod b/lib/CPANPLUS/Hacking.pod new file mode 100644 index 0000000000..c89a403966 --- /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<http://p4.elixus.org/snap/cpanplus-dist.tar.gz> + +And the development branch here: +L<http://p4.elixus.org/snap/cpanplus-devel.tar.gz> + +=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<perl Makefile.PL> you will be prompted to configure. +If you have already done so, and merely wish to update the C<Makefile>, +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<Config.pm-orig>, you should +either delete your current config file and reconfigure, or patch your +config file from the new entries in C<Config.pm-orig>. + +=head1 RUNNING CPANPLUS FROM DEVELOPMENT ENVIRONMENT + +If you'd rather not install the development version to your +C<site_perl> directory, that's no problem. You can set your C<PERL5LIB> +environment variable to CPANPLUS' C<lib> 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<SENDING PATCHES> 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<latest> development snapshot, and the bug still +persists there. If so, report the bug to this address: + + cpanplus-devel@lists.sourceforge.net + +A good C<patch> 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<SUPPLYING PATCHES>) + +=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<diff -u> or C<diff -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 0000000000..0ba2529908 --- /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<CPANPLUS::Backend> 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<CPANPLUS::Configure> 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 => '<empty>', no_override => 1 }, + _callbacks => { default => '<empty>', 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<CPANPLUS> 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<asked> 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 0000000000..0961e25807 --- /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 0000000000..10a14e60e3 --- /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 <http://search.cpan.org/dist/ExtUtils-AutoInstall/> 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 <http://search.cpan.org/dist/Test-Simple/>. + +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 0000000000..544d5894f9 --- /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<Archive::Tar> and C<Compress::Zlib>, or with binaries, like +C<gzip> and C<tar>. + +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<extractdir> +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<CPANPLUS::Module> 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<Archive::Tar> or C<Archive::Zip> respectively, or a binary solution +like C<unzip> and C<tar>. + +=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 0000000000..b8ad371fcc --- /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<CPANPLUS::Module::Fake>. + +C<fetchdir> is the place to save the file to. Usually this +information comes from your configuration, but you can override it +expressly if needed. + +C<fetch_from> 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<force> forces a new download, even if the file already exists. + +C<verbose> simply indicates whether or not to print extra messages. + +C<prefer_bin> 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<File::Fetch> do the actual fetching. + +Returns the path of the output file on success, false on failure. + +Note that you can set a C<blacklist> on certain methods in the config. +Simply add the identifying name of the method (ie, C<lwp>) to: + $conf->_set_fetch( blacklist => ['lwp'] ); + +And the C<LWP> function will be skipped by C<File::Fetch>. + +=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<CPANPLUS::Internals::Fetch> +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 0000000000..ffcb4f0d33 --- /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<http://testers.cpan.org> using the C<Test::Reporter> module. + +All methods will be called automatically if you have C<CPANPLUS> +configured to enable test reporting (see the C<SYNOPSIS>). + +=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<http://testers.cpan.org/> for test results of specified module objects, +module names or distributions. + +The optional argument C<all_versions> 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<cpan-testers@perl.org> 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<cpan-testers@perl.org>. + +=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 0000000000..30443f09fd --- /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<CPANPLUS::Module> objects. +This is a required argument. + +=item allow + +A set of rules, or more precisely, a list of regexes (via C<qr//> or +plain strings), that the C<type> must adhere too. You can specify as +many as you like, and it will be treated as an C<OR> search. +For an C<AND> search, see the C<data> argument. + +This is a required argument. + +=item data + +An arrayref of previous search results. This is the way to do an C<AND> +search -- C<_search_module_tree> will only search the module objects +specified in C<data> 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<CPANPLUS::Module::Author> +objects. This is a required argument. + +=item allow + + +A set of rules, or more precisely, a list of regexes (via C<qr//> or +plain strings), that the C<type> must adhere too. You can specify as +many as you like, and it will be treated as an C<OR> search. +For an C<AND> search, see the C<data> argument. + +This is a required argument. + +=item data + +An arrayref of previous search results. This is the way to do an C<and> +search -- C<_search_author_tree> will only search the author objects +specified in C<data> 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 0000000000..c58632b355 --- /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<CPANPLUS>. + +Functions exist to check if source files are still C<good to use> 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<update_source> 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 I<storable>d 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 I<storable>d format if +C<Storable> 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 0000000000..625160831b --- /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<CPANPLUS::Internals::Utils> 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<host> 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<cwd> 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<Foo-Bar-1.2.tar.gz> 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 0000000000..56566436a1 --- /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 0000000000..96030d30e6 --- /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<CPANPLUS::Module> 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<fake> objects, +there's the C<CPANPLUS::Module::Fake> class. To obtain a module object +consult the C<CPANPLUS::Backend> 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<CPANPLUS::Module::Status> object associated with this object. +(see below). + +=item author + +The C<CPANPLUS::Module::Author> object associated with this object. + +=item parent + +The C<CPANPLUS::Internals> 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<CPANPLUS> caches a lot of results from method calls and saves data +it collected along the road for later reuse. + +C<CPANPLUS> 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<CPANPLUS::Dist::MM> +or C<CPANPLUS::Dist::Build> 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<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build> 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<ports> format, this may be a +C<CPANPLUS::Dist::Ports> 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<create> call to your dist object was done +successfully. + +=item installed + +Flag indicating if the C<install> 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<CPANPLUS::Module> object. Normal users +should never call this method directly, but instead use the +C<CPANPLUS::Backend> to obtain module objects. + +This example illustrates a C<new()> 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<new>. + +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<Acme::Bleach> +that might be C<Acme-Bleach>. + +=head2 $mod->package_version + +Returns the version of the package a module is in. For a module +in the package C<Acme-Bleach-1.1.tar.gz> 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<Acme-Bleach-1.1.tar.gz>, this +would be C<tar.gz>. + +=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<ANY VERSION> 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<Bundle::>. + +=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<Module::ThirdParty> 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<module_information()> in +L<Module::ThirdParty> 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<CPANPLUS::Module::Status> object, as well as +a fake C<CPANPLUS::Module::Author> 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<CPANPLUS::Internals::Fetch::_fetch()> 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<CPANPLUS::Internals::Extract::_extract()> 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<build> or +C<makemaker>. If C<Module::Build> is unavailable or no installer type +is available, it will fall back to C<makemaker>. If both are available, +it will pick the one indicated by your config, or by the +C<prefer_makefile> 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<args> hashref is passed on to the specific distribution +types' C<create> method after being dereferenced. + +Returns a distribution object on success, false on failure. + +See C<CPANPLUS::Dist> 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<install()> that prepares a module +without actually building it. This is equivalent to invoking C<install> +with C<target> set to C<prepare> + +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<install()> that creates a module. +This is equivalent to invoking C<install> with C<target> set to +C<create> + +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<install()> that tests a module, without +installing it. +It's the equivalent to invoking C<install()> with C<target> set to +C<create> and C<skiptest> 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<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and +C<CPANPLUS::Dist> 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<extract()> 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<Time::HiRes> 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<Archive::Tar> 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<http://testers.cpan.org/> for test results of specified module +objects, module names or distributions. + +Look at L<CPANPLUS::Internals::Report::_query_report()> 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<man> pages or C<prog>ram +files. Alternately you can specify C<all> 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<ports> or C<apt>, 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<ExtUtils::Packlist> 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<OBSOLETE> + +If a newer version of Module::Build is found in your path, it will +return this C<special> path. If the newest version of C<Module::Build> +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<CPANPLUS::Dist::*> 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 E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=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 0000000000..95de09cb7a --- /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<CPANPLUS::Module::Author> 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<fake> objects, +there's the C<CPANPLUS::Module::Author::Fake> 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<CPANPLUS::Internals::Object> 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<CPANPLUS::Module::Author> 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 0000000000..115c29ed7b --- /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<CPANPLUS::Module::Author>. + +=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 0000000000..92a2cc27f3 --- /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<CPANPLUS::Module>. + +=head1 METHODS + +=head2 $mod->checksums + +Fetches the checksums file for this module object. +For the options it can take, see C<CPANPLUS::Module::fetch()>. + +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 0000000000..84d0233cf8 --- /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<CPANPLUS::Module>. + +=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 0000000000..cec6f2906b --- /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 0000000000..2271dd4b17 --- /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<latest> 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<CPANPLUS::Selfupdate::Module> objects which +represent the modules required to support this feature. + +For a list of features, call the C<list_features> method. + +If the C<AS_HASH> 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<CPANPLUS::Selfupdate::Module> objects which +represent the modules that comprise the core dependencies of CPANPLUS. + +If the C<AS_HASH> 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<CPANPLUS::Selfupdate::Module> objects which +represent the modules that comprise the core of CPANPLUS. + +If the C<AS_HASH> 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<CPANPLUS::Selfupdate::Module> extends C<CPANPLUS::Module> objects +by providing accessors to aid in selfupdating CPANPLUS. + +These objects are returned by all methods of C<CPANPLUS::Selfupdate> +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 E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=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 0000000000..4128e03c95 --- /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<CPANPLUS> +shells. Through this module you can load any installed C<CPANPLUS> +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 <bug-cpanplus\@rt.cpan.org>."), "\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 E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell::Classic>, L<cpanp> + +=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 0000000000..176548c4f3 --- /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 <your 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 <gisle@ActiveState.com>) + # 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 <scott@gossamer-threads.com>) + # 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<CPAN>. + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author> + +=cut + + +=head1 SEE ALSO + +L<CPAN> + +=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 0000000000..c65cb88d37 --- /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 <URI> # 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 <PLUGIN> + + ### 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<CPANPLUS>. You +can start it via the C<cpanp> binary, or as detailed in the L<SYNOPSIS>. + +=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 E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Classic>, L<CPANPLUS::Shell>, L<cpanp> + +=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 0000000000..c537c4ea72 --- /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<CPANPLUS::Shell::Default>. + +=head1 HOWTO + +=head2 Registering Plugin Modules + +Plugins are detected by using C<Module::Pluggable>. Every module in +the C<CPANPLUS::Shell::Default::Plugins::*> 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<plugins> 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</helloworld> command, +this command will be dispatched to the plugin, and it's C<hw> method will +be called + +=head2 Registering Plugin Help + +To provide usage information for your plugin, the user of the default shell +can type C</? PLUGIN_COMMAND>. In that case, the function C<PLUGIN_COMMAND_help> +will be called in your plugin package. + +For example, extending the above example, when a user calls C</? helloworld>, +the function C<hw_help> 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 E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp> + +=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 0000000000..c351367da0 --- /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<CPANPLUS::Shell::Default> plugin that allows you to connect +to a machine running an instance of C<CPANPLUS::Daemon>, allowing remote +usage of the C<CPANPLUS Shell>. + +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 E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp> + +=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 0000000000..889b3d3d9b --- /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<CPANPLUS::Shell::Default> 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 E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=head1 SEE ALSO + +L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp> + +=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 0000000000..2fff7563dc --- /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<CPAN> 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<CPANPLUS::Shell::Default>. See the C<CPANPLUS::Dist> 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<CPANPLUS::Dist>, L<CPANPLUS::Module>, L<CPANPLUS::Shell::Default>, +C<cpanp> + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=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 0000000000..b1a8f9e016 --- /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<cpanp> + +B<cpanp> S<[-]B<a>> S<[ --[B<no>-]I<option>... ]> S< I<author>... > + +B<cpanp> S<[-]B<mfitulrcz>> S<[ --[B<no>-]I<option>... ]> S< I<module>... > + +B<cpanp> S<[-]B<d>> S<[ --[B<no>-]I<option>... ]> S<[ --B<fetchdir>=... ]> S< I<module>... > + +B<cpanp> S<[-]B<xb>> S<[ --[B<no>-]I<option>... ]> + +B<cpanp> S<[-]B<o>> S<[ --[B<no>-]I<option>... ]> S<[ I<module>... ]> + +=head1 DESCRIPTION + +This script launches the B<CPANPLUS> utility to perform various operations +from the command line. If it's invoked without arguments, an interactive +shell is executed by default. + +Optionally, it can take a single-letter switch and one or more argument, +to perform the associated action on each arguments. A summary of the +available commands is listed below; C<cpanp -h> provides a detailed list. + + h # help information + v # version information + + a AUTHOR ... # search by author(s) + m MODULE ... # search by module(s) + f MODULE ... # list all releases of a module + + i MODULE ... # install module(s) + t MODULE ... # test module(s) + u MODULE ... # uninstall module(s) + d MODULE ... # download module(s) + l MODULE ... # display detailed information about module(s) + r MODULE ... # display README files of module(s) + c MODULE ... # check for module report(s) from cpan-testers + z MODULE ... # extract module(s) and open command prompt in it + + x # reload CPAN indices + + o [ MODULE ... ] # list installed module(s) that aren't up to date + b # write a bundle file for your configuration + +Each command may be followed by one or more I<options>. If preceded by C<no>, +the corresponding option will be set to C<0>, otherwise it's set to C<1>. + +Example: To skip a module's tests, + + cpanp -i --skiptest MODULE ... + +Valid options for most commands are C<cpantest>, C<debug>, C<flush>, C<force>, +C<prereqs>, C<storable>, C<verbose>, C<md5>, C<signature>, and C<skiptest>; the +'d' command also accepts C<fetchdir>. Please consult L<CPANPLUS::Configure> +for an explanation to their meanings. + +Example: To download a module's tarball to the current directory, + + cpanp -d --fetchdir=. MODULE ... + +=cut + +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/bin/cpanp-run-perl b/lib/CPANPLUS/bin/cpanp-run-perl new file mode 100644 index 0000000000..34e62bddd0 --- /dev/null +++ b/lib/CPANPLUS/bin/cpanp-run-perl @@ -0,0 +1,10 @@ +use strict; +my $old = select STDERR; $|++; # turn on autoflush +select $old; $|++; # turn on autoflush +$0 = shift(@ARGV); # rename the script +my $rv = do($0); # execute the file +die $@ if $@; # die on parse/execute error + +### XXX 'do' returns last statement evaluated, which may be +### undef as well. So don't die in that case. +#die $! if not defined $rv; # die on execute error diff --git a/lib/CPANPLUS/inc.pm b/lib/CPANPLUS/inc.pm new file mode 100644 index 0000000000..000a0ce92a --- /dev/null +++ b/lib/CPANPLUS/inc.pm @@ -0,0 +1,522 @@ +package CPANPLUS::inc; + +=head1 NAME + +CPANPLUS::inc + +=head1 DESCRIPTION + +OBSOLETE + +=cut + +sub original_perl5opt { $ENV{PERL5OPT} }; +sub original_perl5lib { $ENV{PERL5LIB} }; +sub original_inc { @INC }; + +1; + +__END__ + +use strict; +use vars qw[$DEBUG $VERSION $ENABLE_INC_HOOK %LIMIT $QUIET]; +use File::Spec (); +use Config (); + +### 5.6.1. nags about require + bareword otherwise ### +use lib (); + +$QUIET = 0; +$DEBUG = 0; +%LIMIT = (); + +=pod + +=head1 NAME + +CPANPLUS::inc - runtime inclusion of privately bundled modules + +=head1 SYNOPSIS + + ### set up CPANPLUS::inc to do it's thing ### + BEGIN { use CPANPLUS::inc }; + + ### enable debugging ### + use CPANPLUS::inc qw[DEBUG]; + +=head1 DESCRIPTION + +This module enables the use of the bundled modules in the +C<CPANPLUS/inc> directory of this package. These modules are bundled +to make sure C<CPANPLUS> is able to bootstrap itself. It will do the +following things: + +=over 4 + +=item Put a coderef at the beginning of C<@INC> + +This allows us to decide which module to load, and where to find it. +For details on what we do, see the C<INTERESTING MODULES> section below. +Also see the C<CAVEATS> section. + +=item Add the full path to the C<CPANPLUS/inc> directory to C<$ENV{PERL5LIB>. + +This allows us to find our bundled modules even if we spawn off a new +process. Although it's not able to do the selective loading as the +coderef in C<@INC> could, it's a good fallback. + +=back + +=head1 METHODS + +=head2 CPANPLUS::inc->inc_path() + +Returns the full path to the C<CPANPLUS/inc> directory. + +=head2 CPANPLUS::inc->my_path() + +Returns the full path to be added to C<@INC> to load +C<CPANPLUS::inc> from. + +=head2 CPANPLUS::inc->installer_path() + +Returns the full path to the C<CPANPLUS/inc/installers> directory. + +=cut + +{ my $ext = '.pm'; + my $file = (join '/', split '::', __PACKAGE__) . $ext; + + ### os specific file path, if you're not on unix + my $osfile = File::Spec->catfile( split('::', __PACKAGE__) ) . $ext; + + ### this returns a unixy path, compensate if you're on non-unix + my $path = File::Spec->rel2abs( + File::Spec->catfile( split '/', $INC{$file} ) + ); + + ### don't forget to quotemeta; win32 paths are special + my $qm_osfile = quotemeta $osfile; + my $path_to_me = $path; $path_to_me =~ s/$qm_osfile$//i; + my $path_to_inc = $path; $path_to_inc =~ s/$ext$//i; + my $path_to_installers = File::Spec->catdir( $path_to_inc, 'installers' ); + + sub inc_path { return $path_to_inc } + sub my_path { return $path_to_me } + sub installer_path { return $path_to_installers } +} + +=head2 CPANPLUS::inc->original_perl5lib + +Returns the value of $ENV{PERL5LIB} the way it was when C<CPANPLUS::inc> +got loaded. + +=head2 CPANPLUS::inc->original_perl5opt + +Returns the value of $ENV{PERL5OPT} the way it was when C<CPANPLUS::inc> +got loaded. + +=head2 CPANPLUS::inc->original_inc + +Returns the value of @INC the way it was when C<CPANPLUS::inc> got +loaded. + +=head2 CPANPLUS::inc->limited_perl5opt(@modules); + +Returns a string you can assign to C<$ENV{PERL5OPT}> to have a limited +include facility from C<CPANPLUS::inc>. It will roughly look like: + + -I/path/to/cpanplus/inc -MCPANPLUS::inc=module1,module2 + +=cut + +{ my $org_opt = $ENV{PERL5OPT}; + my $org_lib = $ENV{PERL5LIB}; + my @org_inc = @INC; + + sub original_perl5opt { $org_opt || ''}; + sub original_perl5lib { $org_lib || ''}; + sub original_inc { @org_inc, __PACKAGE__->my_path }; + + sub limited_perl5opt { + my $pkg = shift; + my $lim = join ',', @_ or return; + + ### -Icp::inc -Mcp::inc=mod1,mod2,mod3 + my $opt = '-I' . __PACKAGE__->my_path . ' ' . + '-M' . __PACKAGE__ . "=$lim"; + + $opt .= $Config::Config{'path_sep'} . + CPANPLUS::inc->original_perl5opt + if CPANPLUS::inc->original_perl5opt; + + return $opt; + } +} + +=head2 CPANPLUS::inc->interesting_modules() + +Returns a hashref with modules we're interested in, and the minimum +version we need to find. + +It would looks something like this: + + { File::Fetch => 0.06, + IPC::Cmd => 0.22, + .... + } + +=cut + +{ + my $map = { + ### used to have 0.80, but not it was never released by coral + ### 0.79 *should* be good enough for now... asked coral to + ### release 0.80 on 10/3/2006 + 'IPC::Run' => '0.79', + 'File::Fetch' => '0.07', + #'File::Spec' => '0.82', # can't, need it ourselves... + 'IPC::Cmd' => '0.24', + 'Locale::Maketext::Simple' => 0, + 'Log::Message' => 0, + 'Module::Load' => '0.10', + 'Module::Load::Conditional' => '0.07', + 'Params::Check' => '0.22', + 'Term::UI' => '0.05', + 'Archive::Extract' => '0.07', + 'Archive::Tar' => '1.23', + 'IO::Zlib' => '1.04', + 'Object::Accessor' => '0.03', + 'Module::CoreList' => '1.97', + 'Module::Pluggable' => '2.4', + 'Module::Loaded' => 0, + #'Config::Auto' => 0, # not yet, not using it yet + }; + + sub interesting_modules { return $map; } +} + + +=head1 INTERESTING MODULES + +C<CPANPLUS::inc> doesn't even bother to try find and find a module +it's not interested in. A list of I<interesting modules> can be +obtained using the C<interesting_modules> method described above. + +Note that all subclassed modules of an C<interesting module> will +also be attempted to be loaded, but a version will not be checked. + +When it however does encounter a module it is interested in, it will +do the following things: + +=over 4 + +=item Loop over your @INC + +And for every directory it finds there (skipping all non directories +-- see the C<CAVEATS> section), see if the module requested can be +found there. + +=item Check the version on every suitable module found in @INC + +After a list of modules has been gathered, the version of each of them +is checked to find the one with the highest version, and return that as +the module to C<use>. + +This enables us to use a recent enough version from our own bundled +modules, but also to use a I<newer> module found in your path instead, +if it is present. Thus having access to bugfixed versions as they are +released. + +If for some reason no satisfactory version could be found, a warning +will be emitted. See the C<DEBUG> section for more details on how to +find out exactly what C<CPANPLUS::inc> is doing. + +=back + +=cut + +{ my $Loaded; + my %Cache; + + + ### returns the path to a certain module we found + sub path_to { + my $self = shift; + my $mod = shift or return; + + ### find the directory + my $path = $Cache{$mod}->[0][2] or return; + + ### probe them explicitly for a special file, because the + ### dir we found the file in vs our own paths may point to the + ### same location, but might not pass an 'eq' test. + + ### it's our inc-path + return __PACKAGE__->inc_path + if -e File::Spec->catfile( $path, '.inc' ); + + ### it's our installer path + return __PACKAGE__->installer_path + if -e File::Spec->catfile( $path, '.installers' ); + + ### it's just some dir... + return $path; + } + + ### just a debug method + sub _show_cache { return \%Cache }; + + sub import { + my $pkg = shift; + + ### filter DEBUG, and toggle the global + map { $LIMIT{$_} = 1 } + grep { /DEBUG/ ? ++$DEBUG && 0 : + /QUIET/ ? ++$QUIET && 0 : + 1 + } @_; + + ### only load once ### + return 1 if $Loaded++; + + ### first, add our own private dir to the end of @INC: + { + push @INC, __PACKAGE__->my_path, __PACKAGE__->inc_path, + __PACKAGE__->installer_path; + + ### XXX stop doing this, there's no need for it anymore; + ### none of the shell outs need to have this set anymore +# ### add the path to this module to PERL5OPT in case +# ### we spawn off some programs... +# ### then add this module to be loaded in PERL5OPT... +# { local $^W; +# $ENV{'PERL5LIB'} .= $Config::Config{'path_sep'} +# . __PACKAGE__->my_path +# . $Config::Config{'path_sep'} +# . __PACKAGE__->inc_path; +# +# $ENV{'PERL5OPT'} = '-M'. __PACKAGE__ . ' ' +# . ($ENV{'PERL5OPT'} || ''); +# } + } + + ### next, find the highest version of a module that + ### we care about. very basic check, but will + ### have to do for now. + lib->import( sub { + my $path = pop(); # path to the pm + my $module = $path or return; # copy of the path, to munge + my @parts = split qr!\\|/!, $path; # dirs + file name; could be + # win32 paths =/ + my $file = pop @parts; # just the file name + my $map = __PACKAGE__->interesting_modules; + + ### translate file name to module name + ### could contain win32 paths delimiters + $module =~ s!/|\\!::!g; $module =~ s/\.pm//i; + + my $check_version; my $try; + ### does it look like a module we care about? + my ($interesting) = grep { $module =~ /^$_/ } keys %$map; + ++$try if $interesting; + + ### do we need to check the version too? + ++$check_version if exists $map->{$module}; + + ### we don't care ### + unless( $try ) { + warn __PACKAGE__ .": Not interested in '$module'\n" if $DEBUG; + return; + + ### we're not allowed + } elsif ( $try and keys %LIMIT ) { + unless( grep { $module =~ /^$_/ } keys %LIMIT ) { + warn __PACKAGE__ .": Limits active, '$module' not allowed ". + "to be loaded" if $DEBUG; + return; + } + } + + ### found filehandles + versions ### + my @found; + DIR: for my $dir (@INC) { + next DIR unless -d $dir; + + ### get the full path to the module ### + my $pm = File::Spec->catfile( $dir, @parts, $file ); + + ### open the file if it exists ### + if( -e $pm ) { + my $fh; + unless( open $fh, "$pm" ) { + warn __PACKAGE__ .": Could not open '$pm': $!\n" + if $DEBUG; + next DIR; + } + + my $found; + ### XXX stolen from module::load::conditional ### + while (local $_ = <$fh> ) { + + ### the following regexp comes from the + ### ExtUtils::MakeMaker documentation. + if ( /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) { + + ### this will eval the version in to $VERSION if it + ### was declared as $VERSION in the module. + ### else the result will be in $res. + ### this is a fix on skud's Module::InstalledVersion + + local $VERSION; + my $res = eval $_; + + ### default to '0.0' if there REALLY is no version + ### all to satisfy warnings + $found = $VERSION || $res || '0.0'; + + ### found what we came for + last if $found; + } + } + + ### no version defined at all? ### + $found ||= '0.0'; + + warn __PACKAGE__ .": Found match for '$module' in '$dir' " + ."with version '$found'\n" if $DEBUG; + + ### reset the position of the filehandle ### + seek $fh, 0, 0; + + ### store the found version + filehandle it came from ### + push @found, [ $found, $fh, $dir, $pm ]; + } + + } # done looping over all the dirs + + ### nothing found? ### + unless (@found) { + warn __PACKAGE__ .": Unable to find any module named " + . "'$module'\n" if $DEBUG; + return; + } + + ### find highest version + ### or the one in the same dir as a base module already loaded + ### or otherwise, the one not bundled + ### or otherwise the newest + my @sorted = sort { + _vcmp($b->[0], $a->[0]) || + ($Cache{$interesting} + ?($b->[2] eq $Cache{$interesting}->[0][2]) <=> + ($a->[2] eq $Cache{$interesting}->[0][2]) + : 0 ) || + (($a->[2] eq __PACKAGE__->inc_path) <=> + ($b->[2] eq __PACKAGE__->inc_path)) || + (-M $a->[3] <=> -M $b->[3]) + } @found; + + warn __PACKAGE__ .": Best match for '$module' is found in " + ."'$sorted[0][2]' with version '$sorted[0][0]'\n" + if $DEBUG; + + if( $check_version and + not (_vcmp($sorted[0][0], $map->{$module}) >= 0) + ) { + warn __PACKAGE__ .": Cannot find high enough version for " + ."'$module' -- need '$map->{$module}' but " + ."only found '$sorted[0][0]'. Returning " + ."highest found version but this may cause " + ."problems\n" unless $QUIET; + }; + + ### right, so that damn )#$(*@#)(*@#@ Module::Build makes + ### assumptions about the environment (especially its own tests) + ### and blows up badly if it's loaded via CP::inc :( + ### so, if we find a newer version on disk (which would happen when + ### upgrading or having upgraded, just pretend we didn't find it, + ### let it be loaded via the 'normal' way. + ### can't even load the *proper* one via our CP::inc, as it will + ### get upset just over the fact it's loaded via a non-standard way + if( $module =~ /^Module::Build/ and + $sorted[0][2] ne __PACKAGE__->inc_path and + $sorted[0][2] ne __PACKAGE__->installer_path + ) { + warn __PACKAGE__ .": Found newer version of 'Module::Build::*' " + ."elsewhere in your path. Pretending to not " + ."have found it\n" if $DEBUG; + return; + } + + ### store what we found for this module + $Cache{$module} = \@sorted; + + ### best matching filehandle ### + return $sorted[0][1]; + } ); + } +} + +### XXX copied from C::I::Utils, so there's no circular require here! +sub _vcmp { + my ($x, $y) = @_; + s/_//g foreach $x, $y; + return $x <=> $y; +} + +=pod + +=head1 DEBUG + +Since this module does C<Clever Things> to your search path, it might +be nice sometimes to figure out what it's doing, if things don't work +as expected. You can enable a debug trace by calling the module like +this: + + use CPANPLUS::inc 'DEBUG'; + +This will show you what C<CPANPLUS::inc> is doing, which might look +something like this: + + CPANPLUS::inc: Found match for 'Params::Check' in + '/opt/lib/perl5/site_perl/5.8.3' with version '0.07' + CPANPLUS::inc: Found match for 'Params::Check' in + '/my/private/lib/CPANPLUS/inc' with version '0.21' + CPANPLUS::inc: Best match for 'Params::Check' is found in + '/my/private/lib/CPANPLUS/inc' with version '0.21' + +=head1 CAVEATS + +This module has 2 major caveats, that could lead to unexpected +behaviour. But currently I don't know how to fix them, Suggestions +are much welcomed. + +=over 4 + +=item On multiple C<use lib> calls, our coderef may not be the first in @INC + +If this happens, although unlikely in most situations and not happening +when calling the shell directly, this could mean that a lower (too low) +versioned module is loaded, which might cause failures in the +application. + +=item Non-directories in @INC + +Non-directories are right now skipped by CPANPLUS::inc. They could of +course lead us to newer versions of a module, but it's too tricky to +verify if they would. Therefor they are skipped. In the worst case +scenario we'll find the sufficing version bundled with CPANPLUS. + + +=cut + +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/t/00_CPANPLUS-Inc.t b/lib/CPANPLUS/t/00_CPANPLUS-Inc.t new file mode 100644 index 0000000000..cf78d61f59 --- /dev/null +++ b/lib/CPANPLUS/t/00_CPANPLUS-Inc.t @@ -0,0 +1,190 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; +use Test::More 'no_plan'; + +my $Class = 'CPANPLUS::inc'; +use_ok( $Class ); +can_ok( $Class, qw[original_perl5opt original_perl5lib original_inc] ); + +__END__ + +# XXX CPANPLUS::inc functionality is obsolete, so it is removed + +my $Module = 'Params::Check'; +my $File = File::Spec->catfile(qw|Params Check.pm|); +my $Ufile = 'Params/Check.pm'; +my $Boring = 'IO::File'; +my $Bfile = 'IO/File.pm'; + + + +### now, first element should be a coderef ### +my $code = $INC[0]; +is( ref $code, 'CODE', 'Coderef loaded in @INC' ); + +### check interesting modules ### +{ my $mods = CPANPLUS::inc->interesting_modules(); + ok( $mods, "Retrieved interesting modules list" ); + is( ref $mods, 'HASH', " It's a hashref" ); + ok( scalar(keys %$mods), " With some keys in it" ); + ok( $mods->{$Module}, " Found a module we care about" ); +} + +### checking include path ### +SKIP: { + my $path = CPANPLUS::inc->inc_path(); + ok( $path, "Retrieved include path" ); + ok( -d $path, " Include path is an actual directory" ); + + ### XXX no more files are bundled this way, it's obsolete + #skip "No files actually bundled in perl core", 1 if $ENV{PERL_CORE}; + #ok( -s File::Spec->catfile( $path, $File ), + # " Found '$File' in include path" ); + + ### we don't do this anymore + #my $out = join '', `$^X -V`; my $qm_path = quotemeta $path; + #like( $out, qr/$qm_path/s, " Path found in perl -V output" ); +} + +### back to the coderef ### +### try a boring module ### +{ local $CPANPLUS::inc::DEBUG = 1; + my $warnings; local $SIG{__WARN__} = sub { $warnings .= "@_" }; + + my $rv = $code->($code, $Bfile); + ok( !$rv, "Ignoring boring module" ); + ok( !$INC{$Bfile}, " Boring file not loaded" ); + like( $warnings, qr/CPANPLUS::inc: Not interested in '$Boring'/s, + " Warned about boringness" ); +} + +### try to load a module with windows paths in it (bug [#11177]) +{ local $CPANPLUS::inc::DEBUG = 1; + my $warnings; local $SIG{__WARN__} = sub { $warnings .= "@_" }; + + my $wfile = 'IO\File.pm'; + my $wmod = 'IO::File'; + + my $rv = $code->($code, $wfile); + ok( !$rv, "Ignoring boring win32 module" ); + ok( !$INC{$wfile}, " Boring win32 file not loaded" ); + like( $warnings, qr/CPANPLUS::inc: Not interested in '$wmod'/s, + " Warned about boringness" ); +} + +### try an interesting module ### +{ local $CPANPLUS::inc::DEBUG = 1; + my $warnings; local $SIG{__WARN__} = sub { $warnings .= "@_" }; + + my $rv = $code->($code, $Ufile); + ok( $rv, "Found interesting module" ); + ok( !$INC{$Ufile}, " Interesting file not loaded" ); + like( $warnings, qr/CPANPLUS::inc: Found match for '$Module'/, + " Match noted in warnings" ); + like( $warnings, qr/CPANPLUS::inc: Best match for '$Module'/, + " Best match noted in warnings" ); + + my $contents = do { local $/; <$rv> }; + ok( $contents, " Read contents from filehandle" ); + like( $contents, qr/$Module/s, + " Contents is from '$Module'" ); +} + +### now do some real loading ### +{ use_ok($Module); + ok( $INC{$Ufile}, " Regular use of '$Module'" ); + + use_ok($Boring); + ok( $INC{$Bfile}, " Regular use of '$Boring'" ); +} + +### check we didn't load our coderef anymore than needed ### +{ my $amount = 5; + for( 0..$amount ) { CPANPLUS::inc->import; }; + + my $flag; + map { $flag++ if ref $_ eq 'CODE' } @INC[0..$amount]; + + my $ok = $amount + 1 == $flag ? 0 : 1; + ok( $ok, "Only loaded coderef into \@INC $flag times"); +} + +### check limit funcionality +{ local $CPANPLUS::inc::DEBUG = 1; + my $warnings; local $SIG{__WARN__} = sub { $warnings .= "@_" }; + + ### so we can reload it + delete $INC{$Ufile}; + delete $INC{$Bfile}; + + ### limit to the loading of $Boring; + CPANPLUS::inc->import( $Boring ); + + ok( $CPANPLUS::inc::LIMIT{$Boring}, + "Limit to '$Boring' recorded" ); + + ### try a boring file first + { my $rv = $code->($code, $Bfile); + ok( !$rv, " '$Boring' still not being loaded" ); + ok( !$INC{$Bfile}, ' Is not in %INC either' ); + } + + ### try an interesting one now + { my $rv = $code->( $code, $Ufile ); + ok( !$rv, " '$Module' is not being loaded" ); + ok( !$INC{$Ufile}, ' Is not in %INC either' ); + like( $warnings, qr/CPANPLUS::inc: Limits active, '$Module'/s, + " Warned about limits" ); + } + + ### reset limits, try again + { local %CPANPLUS::inc::LIMIT; + ok( !keys(%CPANPLUS::inc::LIMIT), + " Limits removed" ); + + + my $rv = $code->( $code, $Ufile ); + ok( $rv, " '$Module' is being loaded" ); + + use_ok( $Module ); + ok( $INC{$Ufile}, ' Present in %INC' ); + } +} + +### test limited perl5opt, to include just a few modules +{ my $dash_m = quotemeta '-MCPANPLUS::inc'; + my $dash_i = quotemeta '-I' . CPANPLUS::inc->my_path; + my $orgopt = quotemeta CPANPLUS::inc->original_perl5opt; + + ### first try an empty string; + { my $str = CPANPLUS::inc->limited_perl5opt; + ok( !$str, "limited_perl5opt without args is empty" ); + } + + ### try with one 'modules' + { my $str = CPANPLUS::inc->limited_perl5opt(qw[A]); + ok( $str, "limted perl5opt set for 1 module" ); + like( $str, qr/$dash_m=A\b/, + " -M set properly" ); + like( $str, qr/$dash_i/," -I set properly" ); + like( $str, qr/$orgopt/," Original opts preserved" ); + } + + ### try with more 'modules' + { my $str = CPANPLUS::inc->limited_perl5opt(qw[A B C]); + ok( $str, "limted perl5opt set for 3 modules" ); + like( $str, qr/$dash_m=A,B,C\b/, + " -M set properly" ); + like( $str, qr/$dash_i/," -I set properly" ); + like( $str, qr/$orgopt/," Original opts preserved" ); + } +} + + + + diff --git a/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t b/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t new file mode 100644 index 0000000000..83a4095995 --- /dev/null +++ b/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t @@ -0,0 +1,132 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; + +### make sure to keep the plan -- this is the only test +### supported for 'older' T::H (pre 2.28) -- see Makefile.PL for details +use Test::More tests => 36; + +use Cwd; +use Data::Dumper; +use File::Spec; +use File::Basename; + +use CPANPLUS::Error; +use CPANPLUS::Internals::Utils; + +my $Cwd = File::Spec->rel2abs(cwd()); +my $Class = 'CPANPLUS::Internals::Utils'; +my $Dir = 'foo'; +my $Move = 'bar'; +my $File = 'zot'; + +rmdir $Move if -d $Move; +rmdir $Dir if -d $Dir; + +### test _mdkir ### +{ ok( $Class->_mkdir( dir => $Dir), "Created dir '$Dir'" ); + ok( -d $Dir, " '$Dir' is a dir" ); +} + +### test _chdir ### +{ ok( $Class->_chdir( dir => $Dir), "Chdir to '$Dir'" ); + is( File::Spec->rel2abs(cwd()), File::Spec->rel2abs(File::Spec->catdir($Cwd,$Dir)), + " Cwd() is '$Dir'"); + ok( $Class->_chdir( dir => $Cwd), "Chdir back to '$Cwd'" ); + is( File::Spec->rel2abs(cwd()),$Cwd," Cwd() is '$Cwd'" ); +} + +### test _move ### +{ ok( $Class->_move( file => $Dir, to => $Move ), + "Move from '$Dir' to '$Move'" ); + ok( -d $Move, " Dir '$Move' exists" ); + ok( !-d $Dir, " Dir '$Dir' no longer exists" ); + + + { local $CPANPLUS::Error::ERROR_FH = output_handle(); + + ### now try to move it somewhere it can't ### + ok( !$Class->_move( file => $Move, to => 'inc' ), + " Impossible move detected" ); + like( CPANPLUS::Error->stack_as_string, qr/Failed to move/, + " Expected error found" ); + } +} + +### test _rmdir ### +{ ok( -d $Move, "Dir '$Move' exists" ); + ok( $Class->_rmdir( dir => $Move ), " Deleted dir '$Move'" ); + ok(!-d $Move, " Dir '$Move' no longer exists" ); +} + +### _get_file_contents tests ### +{ my $contents = $Class->_get_file_contents( file => basename($0) ); + ok( $contents, "Got file contents" ); + like( $contents, qr/BEGIN/, " Proper contents found" ); + like( $contents, qr/CPANPLUS/, " Proper contents found" ); +} + +### _perl_version tests ### +{ my $version = $Class->_perl_version( perl => $^X ); + ok( $version, "Perl version found" ); + like( $version, qr/\d.\d.\d/, " Looks like a proper version" ); +} + +### _version_to_number tests ### +{ my $map = { + '1' => '1', + '1.2' => '1.2', + '.2' => '.2', + 'foo' => '0.0', + 'a.1' => '0.0', + }; + + while( my($try,$expect) = each %$map ) { + my $ver = $Class->_version_to_number( version => $try ); + ok( $ver, "Version returned" ); + is( $ver, $expect, " Value as expected" ); + } +} + +### _whoami tests ### +{ sub foo { + my $me = $Class->_whoami; + ok( $me, "_whoami returned a result" ); + is( $me, 'foo', " Value as expected" ); + } + + foo(); +} + +### _mode_plus_w tests ### +{ open my $fh, ">$File" or die "Could not open $File for writing: $!"; + close $fh; + + ### remove perms + ok( -e $File, "File '$File' created" ); + ok( chmod( 000, $File ), " File permissions set to 000" ); + + ok( $Class->_mode_plus_w( file => $File ), + " File permissions set to +w" ); + ok( -w $File, " File is writable" ); + + 1 while unlink $File; + + ok( !-e $File, " File removed" ); +} + + + + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/lib/CPANPLUS/t/01_CPANPLUS-Configure.t b/lib/CPANPLUS/t/01_CPANPLUS-Configure.t new file mode 100644 index 0000000000..274e04f198 --- /dev/null +++ b/lib/CPANPLUS/t/01_CPANPLUS-Configure.t @@ -0,0 +1,142 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use Test::More 'no_plan'; +use Data::Dumper; +use strict; +use CPANPLUS::Internals::Constants; + +### purposely avert messages and errors to a file? ### +my $Trap_Output = @ARGV ? 0 : 1; +my $Config_pm = 'CPANPLUS/Config.pm'; + +### DO NOT FLUSH TILL THE END!!! we depend on all warnings being logged.. + +for my $mod (qw[CPANPLUS::Configure]) { + use_ok($mod) or diag qq[Can't load $mod]; +} + +my $c = CPANPLUS::Configure->new(); +isa_ok($c, 'CPANPLUS::Configure'); + +my $r = $c->conf; +isa_ok( $r, 'CPANPLUS::Config' ); + + +### EU::AI compatibility test ### +{ my $base = $c->_get_build('base'); + ok( defined($base), "Base retrieved by old compat API"); + is( $base, $c->get_conf('base'), " Value as expected" ); +} + +for my $cat ( $r->ls_accessors ) { + + ### what field can they take? ### + my @options = $c->options( type => $cat ); + + ### copy for use on the config object itself + my $accessor = $cat; + my $prepend = ($cat =~ s/^_//) ? '_' : ''; + + my $getmeth = $prepend . 'get_'. $cat; + my $setmeth = $prepend . 'set_'. $cat; + my $addmeth = $prepend . 'add_'. $cat; + + ok( scalar(@options), "Possible options obtained" ); + + ### test adding keys too ### + { my $add_key = 'test_key'; + my $add_val = [1..3]; + + my $found = grep { $add_key eq $_ } @options; + ok( !$found, "Key '$add_key' not yet defined" ); + ok( $c->$addmeth( $add_key => $add_val ), + " $addmeth('$add_key' => VAL)" ); + + ### this one now also exists ### + push @options, $add_key + } + + ### poke in the object, get the actual hashref out ### + my %hash = map { + $_ => $r->$accessor->$_ + } $r->$accessor->ls_accessors; + + while( my ($key,$val) = each %hash ) { + my $is = $c->$getmeth($key); + is_deeply( $val, $is, "deep check for '$key'" ); + ok( $c->$setmeth($key => 1 ), " $setmeth('$key' => 1)" ); + is( $c->$getmeth($key), 1, " $getmeth('$key')" ); + ok( $c->$setmeth($key => $val), " $setmeth('$key' => ORGVAL)" ); + } + + ### now check if we found all the keys with options or not ### + delete $hash{$_} for @options; + ok( !(scalar keys %hash), "All possible keys found" ); + +} + + +### see if we can save the config ### +{ my $dir = File::Spec->rel2abs('dummy-cpanplus'); + my $pm = 'CPANPLUS::Config::Test' . $$; + my $file = $c->save( $pm, $dir ); + + ok( $file, "Config $pm saved" ); + ok( -e $file, " File exists" ); + ok( -s $file, " File has size" ); + + ### include our dummy dir when re-scanning + { local @INC = ( $dir, @INC ); + ok( $c->init( rescan => 1 ), + "Reran ->init()" ); + } + + ### make sure this file is now loaded + ### XXX can't trust bloody dir seperators on Win32 in %INC, + ### so rather than an exact match, do a grep... + my ($found) = grep /\bTest$$/, values %INC; + ok( $found, " Found $file in \%INC" ); + ok( -e $file, " File exists" ); + 1 while unlink $file; + ok(!-e $file, " File removed" ); + +} + +{ local $CPANPLUS::Error::ERROR_FH = output_handle() if $Trap_Output; + + my $env = ENV_CPANPLUS_CONFIG; + local $ENV{$env} = $$; + my $ok = $c->init; + my $stack = CPANPLUS::Error->stack_as_string; + + ok( $ok, "Reran init again" ); + like( $stack, qr/Specifying a config file in your environment/, + " Warning logged" ); +} + + +{ local $CPANPLUS::Error::ERROR_FH = output_handle() if $Trap_Output; + + CPANPLUS::Error->flush; + + { ### try a bogus method call + my $x = $c->flubber('foo'); + my $err = CPANPLUS::Error->stack_as_string; + is ($x, undef, "Bogus method call returns undef"); + like($err, "/flubber/", " Bogus method call recognized"); + } + + CPANPLUS::Error->flush; +} + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/t/02_CPANPLUS-Internals.t b/lib/CPANPLUS/t/02_CPANPLUS-Internals.t new file mode 100644 index 0000000000..a9e85838bf --- /dev/null +++ b/lib/CPANPLUS/t/02_CPANPLUS-Internals.t @@ -0,0 +1,123 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; +use Test::More 'no_plan'; + +use CPANPLUS::Configure; +use CPANPLUS::Backend; +use CPANPLUS::Internals::Constants; +use Module::Load::Conditional qw[can_load]; +use Data::Dumper; + +my $cb = CPANPLUS::Backend->new( CPANPLUS::Configure->new() ); + +isa_ok($cb, 'CPANPLUS::Internals'); +is($cb->_id, $cb->_last_id, "Comparing ID's"); + +### delete/store/retrieve id tests ### +{ my $del = $cb->_remove_id( $cb->_id ); + ok( $del, "ID deleted" ); + isa_ok( $del, "CPANPLUS::Internals" ); + is( $del, $cb, " Deleted ID matches last object" ); + + my $id = $cb->_store_id( $del ); + ok( $id, "ID stored" ); + is( $id, $cb->_id, " Stored proper ID" ); + + my $obj = $cb->_retrieve_id( $id ); + ok( $obj, "Object retrieved from ID" ); + isa_ok( $obj, 'CPANPLUS::Internals' ); + is( $obj->_id, $id, " Retrieved ID properly" ); + + my @obs = $cb->_return_all_objects(); + ok( scalar(@obs), "Returned objects" ); + is( scalar(@obs), 1, " Proper amount of objects found" ); + is( $obs[0]->_id, $id, " Proper ID found on object" ); + + my $lid = $cb->_last_id; + ok( $lid, "Found last registered ID" ); + is( $lid, $id, " ID matches last object" ); + + my $iid = $cb->_inc_id; + ok( $iid, "Incremented ID" ); + is( $iid, $id+1, " ID matched last ID + 1" ); +} + +### host ok test ### +{ + my $host = $cb->configure_object->get_conf('hosts')->[0]; + + is( $cb->_host_ok( host => $host ), 1, "Host ok" ); + is( $cb->_add_fail_host(host => $host), 1, " Host now marked as bad" ); + is( $cb->_host_ok( host => $host ), 0, " Host still bad" ); + ok( $cb->_flush( list => ['hosts'] ), " Hosts flushed" ); + is( $cb->_host_ok( host => $host ), 1, " Host now ok again" ); +} + +### flush loads test +{ my $mod = 'Benchmark'; + my $file = $mod . '.pm'; + + ### XXX whitebox test -- mark this module as unloadable + $Module::Load::Conditional::CACHE->{$mod}->{usable} = 0; + + ok( !can_load( modules => { $mod => 0 }, verbose => 0 ), + "'$mod' not loaded" ); + + ok( $cb->flush('load'), " 'load' cache flushed" ); + ok( can_load( modules => { $mod => 0 }, verbose => 0 ), + " '$mod' loaded" ); +} + +### callback registering tests ### +{ 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_test_report => $$, # munge the test report + filter_prereqs => $$, # limit prereqs + }; + + for my $callback ( keys %$callback_map ) { + + { local $CPANPLUS::Error::ERROR_FH = output_handle() unless @ARGV; + + my $rv = $callback_map->{$callback}; + + is( $rv, $cb->_callbacks->$callback->( $0, $$ ), + "Default callback '$callback' called" ); + like( CPANPLUS::Error->stack_as_string, qr/DEFAULT '\S+' HANDLER/s, + " Default handler warning recorded" ); + CPANPLUS::Error->flush; + } + + ### try to register the callback + my $ok = $cb->_register_callback( + name => $callback, + code => sub { return $callback } + ); + + ok( $ok, "Registered callback '$callback' ok" ); + + my $sub = $cb->_callbacks->$callback; + ok( $sub, " Retrieved callback" ); + ok( IS_CODEREF->($sub), " Callback is a sub" ); + + my $rv = $sub->(); + ok( $rv, " Callback called ok" ); + is( $rv, $callback, " Got expected return value" ); + } +} + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t b/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t new file mode 100644 index 0000000000..b1d5c04016 --- /dev/null +++ b/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t @@ -0,0 +1,45 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; + +use CPANPLUS::Backend; + +use Test::More 'no_plan'; +use Data::Dumper; + +my $conf = gimme_conf(); + +my $cb = CPANPLUS::Backend->new( $conf ); +isa_ok($cb, "CPANPLUS::Internals" ); + +my $mt = $cb->_module_tree; +my $at = $cb->_author_tree; +my $modname = TEST_CONF_MODULE; + +for my $name (qw[auth mod dslip] ) { + my $file = File::Spec->catfile( + $conf->get_conf('base'), + $conf->_get_source($name) + ); + ok( (-e $file && -f _ && -s _), "$file exists" ); +} + +ok( scalar keys %$at, "Authortree loaded successfully" ); +ok( scalar keys %$mt, "Moduletree loaded successfully" ); + +my $auth = $at->{'EUNOXS'}; +my $mod = $mt->{$modname}; + +isa_ok( $auth, 'CPANPLUS::Module::Author' ); +isa_ok( $mod, 'CPANPLUS::Module' ); + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/t/04_CPANPLUS-Module.t b/lib/CPANPLUS/t/04_CPANPLUS-Module.t new file mode 100644 index 0000000000..81874ddc80 --- /dev/null +++ b/lib/CPANPLUS/t/04_CPANPLUS-Module.t @@ -0,0 +1,302 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; + +use CPANPLUS::Configure; +use CPANPLUS::Backend; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author::Fake; +use CPANPLUS::Internals::Constants; + +use Test::More 'no_plan'; +use Data::Dumper; +use File::Path (); + +### silence errors, unless you tell us not to ### +local $CPANPLUS::Error::ERROR_FH = output_handle() unless @ARGV; + +my $Conf = gimme_conf(); +my $CB = CPANPLUS::Backend->new( $Conf ); + +### start with fresh sources ### +ok( $CB->reload_indices( update_source => 0 ), "Rebuilding trees" ); + +my $AuthName = 'EUNOXS'; +my $Auth = $CB->author_tree( $AuthName ); +my $ModName = TEST_CONF_MODULE; +my $Mod = $CB->module_tree( $ModName ); +my $CoreName = TEST_CONF_PREREQ; +my $CoreMod = $CB->module_tree( $CoreName ); + +isa_ok( $Auth, 'CPANPLUS::Module::Author' ); +isa_ok( $Mod, 'CPANPLUS::Module' ); +isa_ok( $CoreMod, 'CPANPLUS::Module' ); + +### author accessors ### +is( $Auth->author, 'ExtUtils::MakeMaker No XS Code', + "Author name: " . $Auth->author ); +is( $Auth->cpanid, $AuthName, "Author CPANID: " . $Auth->cpanid ); +is( $Auth->email, DEFAULT_EMAIL,"Author email: " . $Auth->email ); +isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); + +### module accessors ### +{ my %map = ( + ### method ### result + module => $ModName, + name => $ModName, + comment => undef, + package => 'Foo-Bar-0.01.tar.gz', + path => 'authors/id/E/EU/EUNOXS', + version => '0.01', + dslip => 'cdpO ', + description => 'CPANPLUS Test Package', + mtime => '', + author => $Auth, + ); + + my @acc = $Mod->accessors; + ok( scalar(@acc), "Retrieved module accessors" ); + + ### remove private accessors + is_deeply( [ sort keys %map ], [ sort grep { $_ !~ /^_/ } @acc ], + " About to test all accessors" ); + + ### check all the accessors + while( my($meth,$res) = each %map ) { + is( $Mod->$meth, $res, " Mod->$meth: " . ($res || '<empty>') ); + } + + ### check accessor objects ### + isa_ok( $Mod->parent, 'CPANPLUS::Backend' ); + isa_ok( $Mod->author, 'CPANPLUS::Module::Author' ); + is( $Mod->author->author, $Auth->author, + "Module eq Author" ); +} + +### convenience methods ### +{ ok( 1, "Convenience functions" ); + is( $Mod->package_name, 'Foo-Bar', " Package name"); + is( $Mod->package_version, '0.01', " Package version"); + is( $Mod->package_extension, 'tar.gz', " Package extension"); + ok( !$Mod->package_is_perl_core, " Package not core"); + ok( !$Mod->module_is_supplied_with_perl_core, " Module not core" ); + ok( !$Mod->is_bundle, " Package not bundle"); +} + +### clone & status tests +{ my $clone = $Mod->clone; + ok( $clone, "Module cloned" ); + isa_ok( $clone, 'CPANPLUS::Module' ); + + for my $acc ( $Mod->accessors ) { + is( $clone->$acc, $Mod->$acc, + " Clone->$acc matches Mod->$acc " ); + } + + ### XXX whitebox test + ok( !$clone->_status, "Status object empty on start" ); + + my $status = $clone->status; + ok( $status, " Status object defined after query" ); + is( $status, $clone->_status, + " Object stored as expected" ); + isa_ok( $status, 'Object::Accessor' ); +} + +{ ### extract + error test ### + ok( !$Mod->extract(), "Cannot extract unfetched file" ); + like( CPANPLUS::Error->stack_as_string, qr/You have not fetched/, + " Error properly logged" ); +} + +{ ### fetch tests ### + ### enable signature checks for checksums ### + my $old = $Conf->get_conf('signature'); + $Conf->set_conf(signature => 1); + + my $where = $Mod->fetch( force => 1 ); + ok( $where, "Module fetched" ); + ok( -f $where, " Module is a file" ); + ok( -s $where, " Module has size" ); + + $Conf->set_conf( signature => $old ); +} + +{ ### extract tests ### + my $dir = $Mod->extract( force => 1 ); + ok( $dir, "Module extracted" ); + ok( -d $dir, " Dir exsits" ); +} + + +{ ### readme tests ### + my $readme = $Mod->readme; + ok( length $readme, "Readme found" ); + is( $readme, $Mod->status->readme, + " Readme stored in module object" ); +} + +{ ### checksums tests ### + SKIP: { + skip(q[You chose not to enable checksum verification], 5) + unless $Conf->get_conf('md5'); + + my $cksum_file = $Mod->checksums( force => 1 ); + ok( $cksum_file, "Checksum file found" ); + is( $cksum_file, $Mod->status->checksums, + " File stored in module object" ); + ok( -e $cksum_file, " File exists" ); + ok( -s $cksum_file, " File has size" ); + + ### XXX test checksum_value if there's digest::md5 + config wants it + ok( $Mod->status->checksum_ok, + " Checksum is ok" ); + } +} + + +{ ### installer type tests ### + my $installer = $Mod->get_installer_type; + ok( $installer, "Installer found" ); + is( $installer, INSTALLER_MM, + " Proper installer found" ); +} + +{ ### check signature tests ### + SKIP: { + skip(q[You chose not to enable signature checks], 1) + unless $Conf->get_conf('signature'); + + ok( $Mod->check_signature, + "Signature check OK" ); + } +} + +{ ### details() test ### + my $href = { + 'Support Level' => 'Developer', + 'Package' => $Mod->package, + 'Description' => $Mod->description, + 'Development Stage' => + 'under construction but pre-alpha (not yet released)', + 'Author' => sprintf("%s (%s)", $Auth->author, $Auth->email), + 'Version on CPAN' => $Mod->version, + 'Language Used' => + 'Perl-only, no compiler needed, should be platform independent', + 'Interface Style' => + 'Object oriented using blessed references and/or inheritance', + 'Public License' => 'Unknown', + ### XXX we can't really know what you have installed ### + #'Version Installed' => '0.06', + }; + + my $res = $Mod->details; + + ### delete they key of which we don't know the value ### + delete $res->{'Version Installed'}; + + is_deeply( $res, $href, "Details OK" ); +} + +{ ### contians() test ### + ### XXX ->contains works based on package name. in our sourcefiles + ### we use 4x the same package name for different modules. So use + ### the only unique package name here, which is the one for the core mod + my @list = $CoreMod->contains; + + ok( scalar(@list), "Found modules contained in this one" ); + is_deeply( \@list, [$CoreMod], + " Found all modules expected" ); +} + +{ ### testing distributions() ### + my @mdists = $Mod->distributions; + is( scalar @mdists, 1, "Distributions found via module" ); + + my @adists = $Auth->distributions; + is( scalar @adists, 3, "Distributions found via author" ); +} + +{ ### test status->flush ### + ok( $Mod->status->mk_flush, + "Status flushed" ); + ok(!$Mod->status->fetch," Fetch status empty" ); + ok(!$Mod->status->extract, + " Extract status empty" ); + ok(!$Mod->status->checksums, + " Checksums status empty" ); + ok(!$Mod->status->readme, + " Readme status empty" ); +} + +{ ### testing bundles ### + my $bundle = $CB->module_tree('Bundle::Foo::Bar'); + isa_ok( $bundle, 'CPANPLUS::Module' ); + + ok( $bundle->is_bundle, " It's a Bundle:: module" ); + ok( $bundle->fetch, " Fetched the bundle" ); + ok( $bundle->extract, " Extracted the bundle" ); + + my @objs = $bundle->bundle_modules; + is( scalar(@objs), 5, " Found all prerequisites" ); + + for( @objs ) { + isa_ok( $_, 'CPANPLUS::Module', + " Prereq " . $_->module ); + ok( defined $bundle->status->prereqs->{$_->module}, + " Prereq was registered" ); + } +} + +### test module from perl core ### +{ isa_ok( $CoreMod, 'CPANPLUS::Module', + "Core module " . $CoreName ); + ok( $CoreMod->package_is_perl_core, + " Package found in perl core" ); + + ### check if it's core with 5.6.1 + { local $] = '5.006001'; + ok( $CoreMod->module_is_supplied_with_perl_core, + " Module also found in perl core"); + } + + ok( !$CoreMod->install, " Package not installed" ); + like( CPANPLUS::Error->stack_as_string, qr/core Perl/, + " Error properly logged" ); +} + +### test third-party modules +SKIP: { + skip "Module::ThirdParty not installed", 10 + unless eval { require Module::ThirdParty; 1 }; + + ok( !$Mod->is_third_party, + "Not a 3rd party module: ". $Mod->name ); + + my $fake = $CB->parse_module( module => 'LOCAL/SVN-Core-1.0' ); + ok( $fake, "Created module object for ". $fake->name ); + ok( $fake->is_third_party, + " It is a 3rd party module" ); + + my $info = $fake->third_party_information; + ok( $info, "Got 3rd party package information" ); + isa_ok( $info, 'HASH' ); + + for my $item ( qw[name url author author_url] ) { + ok( length($info->{$item}), + " $item field is filled" ); + } +} + +### testing EU::Installed methods in Dist::MM tests ### + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t b/lib/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t new file mode 100644 index 0000000000..f58b932c98 --- /dev/null +++ b/lib/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t @@ -0,0 +1,113 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; + +use CPANPLUS::Backend; + +use Test::More 'no_plan'; +use Data::Dumper; +use File::Spec; +use Cwd; +use File::Basename; +use CPANPLUS::Internals::Constants; + +my $conf = gimme_conf(); + +### Redirect errors to file ### +local $CPANPLUS::Error::ERROR_FH = output_handle() unless @ARGV; +local $CPANPLUS::Error::MSG_FH = output_handle() unless @ARGV; + +my $cb = CPANPLUS::Backend->new( $conf ); +isa_ok($cb, "CPANPLUS::Internals" ); + +my $mod = $cb->module_tree( TEST_CONF_MODULE ); +isa_ok( $mod, 'CPANPLUS::Module' ); + +### fail host tests ### +{ my $host = {}; + my $rv = $cb->_add_fail_host( host => $host ); + + ok( $rv, "Failed host added " ); + ok(!$cb->_host_ok( host => $host), + " Host registered as failed" ); + ok( $cb->_host_ok( host => {} ), + " Fresh host unregistered" ); +} + +### refetch, even if it's there already ### +{ my $where = $cb->_fetch( module => $mod, force => 1 ); + + ok( $where, "File downloaded to '$where'" ); + ok( -s $where, " File exists" ); + unlink $where; + ok(!-e $where, " File removed" ); +} + +### try to fetch something that doesn't exist ### +{ ### set up a bogus host first ### + my $hosts = $conf->get_conf('hosts'); + my $fail = { scheme => 'file', + path => "$0/$0" }; + + unshift @$hosts, $fail; + $conf->set_conf( hosts => $hosts ); + + ### the fallback host will get it ### + my $where = $cb->_fetch( module => $mod, force => 1, verbose => 0 ); + ok($where, "File downloaded to '$where'" ); + ok( -s $where, " File exists" ); + + ### but the error should be recorded ### + like( CPANPLUS::Error->stack_as_string, qr/Fetching of .*? failed/s, + " Error recorded appropriately" ); + + ### host marked as bad? ### + ok(!$cb->_host_ok( host => $fail ), + " Failed host logged properly" ); + + ### restore the hosts ### + shift @$hosts; $conf->set_conf( hosts => $hosts ); +} + +### try and fetch a URI +{ my $base = basename($0); + + ### do an ON_UNIX test, cygwin will fail tests otherwise (#14553) + ### create a file URI. Make sure to split it by LOCAL rules + ### and JOIN by unix rules, so we get a proper file uri + ### otherwise, we might break win32. See bug #18702 + my $target = CREATE_FILE_URI->( + File::Spec::Unix->catfile( + File::Spec::Unix->catdir( + File::Spec->splitdir( cwd() ), + ), + $base + ) + ); + + my $fake = $cb->parse_module( module => $target ); + + ok( IS_FAKE_MODOBJ->(mod => $fake), + "Fake module created from $0" ); + is( $fake->status->_fetch_from, $target, + " Fetch from set ok" ); + + my $where = $fake->fetch; + ok( $where, " $target fetched ok" ); + ok( -s $where, " $where exists" ); + like( $where, '/'. UNKNOWN_DL_LOCATION .'/', + " Saved to proper location" ); + like( $where, qr/$base$/, " Saved with proper name" ); +} + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t b/lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t new file mode 100644 index 0000000000..2b09fe2241 --- /dev/null +++ b/lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t @@ -0,0 +1,66 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; +use Test::More 'no_plan'; +use Cwd; +use File::Basename; + +use CPANPLUS::Internals::Constants; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author::Fake; +use CPANPLUS::Configure; +use CPANPLUS::Backend; + +my $conf = gimme_conf(); + +my $cb = CPANPLUS::Backend->new( $conf ); + +my $f_auth = CPANPLUS::Module::Author::Fake->new( _id => $cb->_id ); +ok( $f_auth, "Fake auth object created" ); +ok( IS_AUTHOBJ->( $f_auth ), " IS_AUTHOBJ recognizes it" ); +ok( IS_FAKE_AUTHOBJ->( $f_auth ), " IS_FAKE_AUTHOBJ recognizes it" ); + +my $f_mod = CPANPLUS::Module::Fake->new( + module => TEST_CONF_INST_MODULE , + path => 'some/where', + package => 'Foo-Bar-1.2.tgz', + _id => $cb->_id, + ); +ok( $f_mod, "Fake mod object created" ); +ok( IS_MODOBJ->( $f_mod ), " IS_MODOBJ recognizes it" ); +ok( IS_FAKE_MODOBJ->( $f_mod ), " IS_FAKE_MODOJB recognizes it" ); + +ok( IS_CONFOBJ->( conf => $conf ), "IS_CONFOBJ recognizes conf object" ); + +ok( FILE_EXISTS->( file => basename($0) ), "FILE_EXISTS finds file" ); +ok( FILE_READABLE->( file => basename($0) ), "FILE_READABLE finds file" ); +ok( DIR_EXISTS->( dir => cwd() ), "DIR_EXISTS finds dir" ); + + +{ no strict 'refs'; + + my $tmpl = { + MAKEFILE_PL => 'Makefile.PL', + MAKEFILE => 'Makefile', + BUILD_PL => 'Build.PL', + BLIB => 'blib', + }; + + while ( my($sub,$res) = each %$tmpl ) { + is( &{$sub}->(), $res, "$sub returns proper result without args" ); + + my $long = File::Spec->catfile( cwd(), $res ); + is( &{$sub}->( cwd() ), $long, "$sub returns proper result with args" ); + } +} + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t b/lib/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t new file mode 100644 index 0000000000..b03befa8ac --- /dev/null +++ b/lib/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t @@ -0,0 +1,36 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; + +use CPANPLUS::Configure; +use CPANPLUS::Backend; +use CPANPLUS::Internals::Constants; +use Test::More 'no_plan'; +use Data::Dumper; + +my $conf = gimme_conf(); + +my $cb = CPANPLUS::Backend->new( $conf ); + +### XXX SOURCEFILES FIX +my $mod = $cb->module_tree( TEST_CONF_MODULE ); + +isa_ok( $mod, 'CPANPLUS::Module' ); + +my $where = $mod->fetch; +ok( $where, "Module fetched" ); + +my $dir = $cb->_extract( module => $mod ); +ok( $dir, "Module extracted" ); +ok( DIR_EXISTS->($dir), " Dir exists" ); + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/t/08_CPANPLUS-Backend.t b/lib/CPANPLUS/t/08_CPANPLUS-Backend.t new file mode 100644 index 0000000000..571a530284 --- /dev/null +++ b/lib/CPANPLUS/t/08_CPANPLUS-Backend.t @@ -0,0 +1,279 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; +use Test::More 'no_plan'; +use File::Basename 'dirname'; + +use Data::Dumper; +use CPANPLUS::Error; +use CPANPLUS::Internals::Constants; + +my $conf = gimme_conf(); + +### purposely avert messages and errors to a file? ### +my $Trap_Output = @ARGV ? 0 : 1; + +my $Class = 'CPANPLUS::Backend'; +### D::C has troubles with the 'use_ok' -- it finds the wrong paths. +### for now, do a 'use' instead +#use_ok( $Class ) or diag "$Class not found"; +use CPANPLUS::Backend; + +my $cb = $Class->new( $conf ); +isa_ok( $cb, $Class ); + +my $mt = $cb->module_tree; +my $at = $cb->author_tree; +ok( scalar keys %$mt, "Module tree has entries" ); +ok( scalar keys %$at, "Author tree has entries" ); + +### module_tree tests ### +my $Name = TEST_CONF_MODULE; +my $mod = $cb->module_tree($Name); + +### XXX SOURCEFILES FIX +{ my @mods = $cb->module_tree($Name,$Name); + my $none = $cb->module_tree( TEST_CONF_INVALID_MODULE ); + + ok( IS_MODOBJ->(mod => $mod), "Module object found" ); + is( scalar(@mods), 2, " Module list found" ); + ok( IS_MODOBJ->(mod => $mods[0]), " ISA module object" ); + ok( !IS_MODOBJ->(mod => $none), " Bogus module detected"); +} + +### author_tree tests ### +{ my @auths = $cb->author_tree( $mod->author->cpanid, + $mod->author->cpanid ); + my $none = $cb->author_tree( 'fnurk' ); + + ok( IS_AUTHOBJ->(auth => $mod->author), "Author object found" ); + is( scalar(@auths), 2, " Author list found" ); + ok( IS_AUTHOBJ->( author => $auths[0] )," ISA author object" ); + is( $mod->author, $auths[0], " Objects are identical" ); + ok( !IS_AUTHOBJ->( author => $none ), " Bogus author detected" ); +} + +my $conf_obj = $cb->configure_object; +ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); + + +### parse_module tests ### +{ my @map = ( # author package version + $Name => [ $mod->author->cpanid, $mod->package_name, $mod->version ], + $mod => [ $mod->author->cpanid, $mod->package_name, $mod->version ], + 'Foo-Bar-EU-NOXS' + => [ $mod->author->cpanid, $mod->package_name, $mod->version ], + 'Foo-Bar-EU-NOXS-0.01' + => [ $mod->author->cpanid, $mod->package_name, '0.01' ], + 'EUNOXS/Foo-Bar-EU-NOXS' + => [ 'EUNOXS', $mod->package_name, $mod->version ], + 'EUNOXS/Foo-Bar-EU-NOXS-0.01' + => [ 'EUNOXS', $mod->package_name, '0.01' ], + 'Foo-Bar-EU-NOXS-0.09' + => [ $mod->author->cpanid, $mod->package_name, '0.09' ], + 'MBXS/Foo-Bar-EU-NOXS-0.01' + => [ 'MBXS', $mod->package_name, '0.01' ], + 'EUNOXS/Foo-Bar-EU-NOXS-0.09' + => [ 'EUNOXS', $mod->package_name, '0.09' ], + 'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip' + => [ 'EUNOXS', $mod->package_name, '0.09' ], + 'FROO/Flub-Flob-1.1.zip' + => [ 'FROO', 'Flub-Flob', '1.1' ], + 'G/GO/GOYALI/SMS_API_3_01.tar.gz' + => [ 'GOYALI', 'SMS_API', '3_01' ], + 'E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091' + => [ 'EYCK', 'Net-Lite-FTP', '0.091' ], + 'EYCK/Net/Lite/Net-Lite-FTP-0.091' + => [ 'EYCK', 'Net-Lite-FTP', '0.091' ], + 'M/MA/MAXDB/DBD-MaxDB-7.5.00.24a' + => [ 'MAXDB', 'DBD-MaxDB', '7.5.00.24a' ], + 'EUNOXS/perl5.005_03.tar.gz' + => [ 'EUNOXS', 'perl', '5.005_03' ], + 'FROO/Flub-Flob-v1.1.0.tbz' + => [ 'FROO', 'Flub-Flob', 'v1.1.0' ], + 'FROO/Flub-Flob-1.1_2.tbz' + => [ 'FROO', 'Flub-Flob', '1.1_2' ], + 'LDS/CGI.pm-3.27.tar.gz' + => [ 'LDS', 'CGI', '3.27' ], + 'FROO/Text-Tabs+Wrap-2006.1117.tar.gz' + => [ 'FROO', 'Text-Tabs+Wrap', '2006.1117' ], + 'JETTERO/Crypt-PBC-0.7.20.0-0.4.9', + => [ 'JETTERO', 'Crypt-PBC', '0.7.20.0-0.4.9' ], + + ); + + while ( my($guess, $attr) = splice @map, 0, 2 ) { + my( $author, $pkg, $version ) = @$attr; + + ok( $guess, "Attempting to parse $guess" ); + + my $obj = $cb->parse_module( module => $guess ); + + ok( $obj, " Result returned" ); + ok( IS_MODOBJ->( mod => $obj ), + " parse_module success by '$guess'" ); + + is( $obj->version, $version, + " Proper version found: $version" ); + is( $obj->package_version, $version, + " Found in package_version as well" ); + is( $obj->package_name, $pkg, + " Proper package found: $pkg" ); + unlike( $obj->package_name, qr/\d/, + " No digits in package name" ); + like( $obj->author->cpanid, "/$author/i", + " Proper author found: $author"); + like( $obj->path, "/$author/i", + " Proper path found: " . $obj->path ); + } + + + ### test for things that look like real modules, but aren't ### + { local $CPANPLUS::Error::MSG_FH = output_handle() if $Trap_Output; + local $CPANPLUS::Error::ERROR_FH = output_handle() if $Trap_Output; + + my @map = ( + [ $Name . $$ => [ + [qr/does not contain an author/,"Missing author part detected"], + [qr/Cannot find .+? in the module tree/,"Unable to find module"] + ] ], + [ {}, => [ + [ qr/module string from reference/,"Unable to parse ref"] + ] ], + ); + + for my $entry ( @map ) { + my($mod,$aref) = @$entry; + + my $none = $cb->parse_module( module => $mod ); + ok( !IS_MODOBJ->(mod => $none), + "Non-existant module detected" ); + ok( !IS_FAKE_MODOBJ->(mod => $none), + "Non-existant fake module detected" ); + + my $str = CPANPLUS::Error->stack_as_string; + for my $pair (@$aref) { + my($re,$diag) = @$pair; + like( $str, $re," $diag" ); + } + } + } + + ### test parsing of arbitrary URI + for my $guess ( qw[ http://foo/bar.gz + http://a/b/c/d/e/f/g/h/i/j + flub://floo ] + ) { + my $obj = $cb->parse_module( module => $guess ); + ok( IS_FAKE_MODOBJ->(mod => $obj), "parse_module success by '$guess'" ); + is( $obj->status->_fetch_from, $guess, + " Fetch from set ok" ); + } +} + +### RV tests ### +{ my $method = 'readme'; + my %args = ( modules => [$Name] ); + + my $rv = $cb->$method( %args ); + ok( IS_RVOBJ->( $rv ), "Got an RV object" ); + ok( $rv->ok, " Overall OK" ); + cmp_ok( $rv, '==', 1, " Overload OK" ); + is( $rv->function, $method, " Function stored OK" ); + is_deeply( $rv->args, \%args, " Arguments stored OK" ); + is( $rv->rv->{$Name}, $mod->readme, " RV as expected" ); +} + +### reload_indices tests ### +{ + my $file = File::Spec->catfile( $conf->get_conf('base'), + $conf->_get_source('mod'), + ); + + ok( $cb->reload_indices( update_source => 0 ), "Rebuilding trees" ); + my $age = -M $file; + + ### make sure we are 'newer' on faster machines with a sleep.. + ### apparently Win32's FAT isn't granual enough on intervals + ### < 2 seconds, so it may give the same answer before and after + ### the sleep, causing the test to fail. so sleep atleast 2 seconds. + sleep 2; + ok( $cb->reload_indices( update_source => 1 ), + "Rebuilding and refetching trees" ); + cmp_ok( $age, '>', -M $file, " Source file '$file' updated" ); +} + +### flush tests ### +{ + for my $cache( qw[methods hosts modules lib all] ) { + ok( $cb->flush($cache), "Cache $cache flushed ok" ); + } +} + +### installed tests ### +{ + ok( scalar $cb->installed, "Found list of installed modules" ); +} + +### autobudle tests ### +{ + my $where = $cb->autobundle; + ok( $where, "Autobundle written" ); + ok( -s $where, " File has size" ); +} + +### local_mirror tests ### +{ ### turn off md5 checks for the 'fake' packages we have + my $old_md5 = $conf->get_conf('md5'); + $conf->set_conf( md5 => 0 ); + + ### otherwise 'status->fetch' might be undef! ### + my $rv = $cb->local_mirror( path => 'dummy-localmirror' ); + ok( $rv, "Local mirror created" ); + + for my $mod ( values %{ $cb->module_tree } ) { + my $name = $mod->module; + + my $cksum = File::Spec->catfile( + dirname($mod->status->fetch), + CHECKSUMS ); + ok( -e $mod->status->fetch, " Module '$name' fetched" ); + ok( -s _, " Module '$name' has size" ); + ok( -e $cksum, " Checksum fetched for '$name'" ); + ok( -s _, " Checksum for '$name' has size" ); + } + + $conf->set_conf( md5 => $old_md5 ); +} + +### check ENV variable +{ ### process id + { my $name = 'PERL5_CPANPLUS_IS_RUNNING'; + ok( $ENV{$name}, "Env var '$name' set" ); + is( $ENV{$name}, $$, " Set to current process id" ); + } + + ### Version + { my $name = 'PERL5_CPANPLUS_IS_VERSION'; + ok( $ENV{$name}, "Env var '$name' set" ); + + ### version.pm formats ->VERSION output... *sigh* + is( $ENV{$name}, $Class->VERSION, + " Set to current process version" ); + } + +} + +__END__ + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: + diff --git a/lib/CPANPLUS/t/09_CPANPLUS-Internals-Search.t b/lib/CPANPLUS/t/09_CPANPLUS-Internals-Search.t new file mode 100644 index 0000000000..583d464740 --- /dev/null +++ b/lib/CPANPLUS/t/09_CPANPLUS-Internals-Search.t @@ -0,0 +1,78 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; +use Test::More 'no_plan'; +use Data::Dumper; +use CPANPLUS::Backend; +use CPANPLUS::Internals::Constants; + +my $Conf = gimme_conf(); +my $CB = CPANPLUS::Backend->new($Conf); +my $ModName = TEST_CONF_MODULE; +my $Mod = $CB->module_tree( $ModName ); + + +### search for modules ### +for my $type ( CPANPLUS::Module->accessors() ) { + + ### don't muck around with references/objects + ### or private identifiers + next if ref $Mod->$type() or $type =~/^_/; + + my @aref = $CB->search( + type => $type, + allow => [$Mod->$type()], + ); + + ok( scalar @aref, "Module found by '$type'" ); + for( @aref ) { + ok( IS_MODOBJ->($_)," Module isa module object" ); + } +} + +### search for authors ### +my $auth = $Mod->author; +for my $type ( CPANPLUS::Module::Author->accessors() ) { + my @aref = $CB->search( + type => $type, + allow => [$auth->$type()], + ); + + ok( @aref, "Author found by '$type'" ); + for( @aref ) { + ok( IS_AUTHOBJ->($_), " Author isa author object" ); + } +} + + +{ my $warning = ''; + local $SIG{__WARN__} = sub { $warning .= "@_"; }; + + { ### try search that will yield nothing ### + ### XXX SOURCEFILES FIX + my @list = $CB->search( type => 'module', + allow => [$ModName.$$] ); + + is( scalar(@list), 0, "Valid search yields no results" ); + is( $warning, '', " No warnings issued" ); + } + + { ### try bogus arguments ### + my @list = $CB->search( type => '', allow => ['foo'] ); + + is( scalar(@list), 0, "Broken search yields no results" ); + like( $warning, qr/^Key 'type'.* is of invalid type for/, + " Got a warning for wrong arguments" ); + } +} + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/t/10_CPANPLUS-Error.t b/lib/CPANPLUS/t/10_CPANPLUS-Error.t new file mode 100644 index 0000000000..8a954e7779 --- /dev/null +++ b/lib/CPANPLUS/t/10_CPANPLUS-Error.t @@ -0,0 +1,113 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; +use Test::More 'no_plan'; +use Data::Dumper; +use FileHandle; +use CPANPLUS::Error; + +my $conf = gimme_conf(); + +my $map = { + cp_msg => ["This is just a test message"], + msg => ["This is just a test message"], + cp_error => ["This is just a test error"], + error => ["This is just a test error"], +}; + +### check if CPANPLUS::Error can do what we expect +{ for my $name ( keys %$map ) { + can_ok('CPANPLUS::Error', $name); + can_ok('main', $name); # did it get exported? + } +} + +### make sure we start with an empty stack +{ CPANPLUS::Error->flush; + is( scalar(()=CPANPLUS::Error->stack), 0, + "Starting with empty stack" ); +} + +### global variables test ### +{ my $file = output_file(); + unlink $file; # just in case + + local $CPANPLUS::Error::MSG_FH = output_handle(); + local $CPANPLUS::Error::ERROR_FH = output_handle(); + + ok( -e $file, "Output redirect file exists" ); + ok( !-s $file, " Output file is empty" ); + + ### print a msg & error ### + for my $name ( keys %$map ) { + my $sub = __PACKAGE__->can( $name ); + + $sub->( $map->{$name}->[0], 1 ); + } + + ### must close it for Win32 tests! + close output_handle; + + ok( -s $file, " Output file now has size" ); + + my $fh = FileHandle->new( $file ); + ok( $fh, "Opened output file for reading " ); + + my $contents = do { local $/; <$fh> }; + my $string = CPANPLUS::Error->stack_as_string; + my $trace = CPANPLUS::Error->stack_as_string(1); + + ok( $contents, " Got the file contents" ); + ok( $string, "Got the error stack as string" ); + + + for my $type ( keys %$map ) { + my $tag = $type; $tag =~ s/.+?_//g; + + for my $str (@{ $map->{$type} } ) { + like( $contents, qr/\U\Q$tag/, + " Contents matches for '$type'" ); + like( $contents, qr/\Q$str/, + " Contents matches for '$type'" ); + + like( $string, qr/\U\Q$tag/, + " String matches for '$type'" ); + like( $string, qr/\Q$str/, + " String matches for '$type'" ); + + like( $trace, qr/\U\Q$tag/, + " Trace matches for '$type'" ); + like( $trace, qr/\Q$str/, + " Trace matches for '$type'" ); + + ### extra trace tests ### + like( $trace, qr/\Q$str\E.*?\Q$str/s, + " Trace holds proper traceback" ); + like( $trace, qr/\Q$0/, + " Trace holds program name" ); + like( $trace, qr/line/, + " Trace holds line number information" ); + } + } + + ### check the stack, flush it, check again ### + is( scalar(()=CPANPLUS::Error->stack), scalar(keys(%$map)), + "All items on stack" ); + is( scalar(()=CPANPLUS::Error->flush), scalar(keys(%$map)), + "All items flushed" ); + is( scalar(()=CPANPLUS::Error->stack), 0, + "No items on stack" ); + +} + + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/t/19_CPANPLUS-Dist.t b/lib/CPANPLUS/t/19_CPANPLUS-Dist.t new file mode 100644 index 0000000000..4c48fcaab3 --- /dev/null +++ b/lib/CPANPLUS/t/19_CPANPLUS-Dist.t @@ -0,0 +1,417 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +### dummy class for testing dist api ### +BEGIN { + + package CPANPLUS::Dist::_Test; + use strict; + use vars qw[$Available $Create $Install $Init $Prepare @ISA]; + + @ISA = qw[CPANPLUS::Dist]; + $Available = 1; + $Create = 1; + $Install = 1; + $Init = 1; + $Prepare = 1; + + require CPANPLUS::Dist; + CPANPLUS::Dist->_add_dist_types( __PACKAGE__ ); + + sub init { $_[0]->status->mk_accessors( + qw[prepared created installed + _prepare_args _install_args _create_args]); + return $Init }; + sub format_available { return $Available } + sub prepare { return shift->status->prepared($Prepare) } + sub create { return shift->status->created($Create) } + sub install { return shift->status->installed($Install) } +} + +use strict; + +use CPANPLUS::Configure; +use CPANPLUS::Backend; +use CPANPLUS::Internals::Constants; + +use Test::More 'no_plan'; +use Cwd; +use Data::Dumper; +use File::Basename (); +use File::Spec (); +use Module::Load::Conditional qw[check_install]; + +my $conf = gimme_conf(); +my $cb = CPANPLUS::Backend->new( $conf ); + +### Redirect errors to file ### +local $CPANPLUS::Error::ERROR_FH = output_handle() unless @ARGV; +local $CPANPLUS::Error::MSG_FH = output_handle() unless @ARGV; + +### obsolete +#my $Format = '_test'; +my $Module = 'CPANPLUS::Dist::_Test'; +my $ModName = TEST_CONF_MODULE; +my $ModPrereq = TEST_CONF_INST_MODULE; +### XXX this version doesn't exist, but we don't check for it either ### +my $Prereq = { $ModPrereq => '1000' }; + +### since it's in this file, not in it's own module file, +### make M::L::C think it already was loaded +$Module::Load::Conditional::CACHE->{$Module}->{usable} = 1; + + +use_ok('CPANPLUS::Dist'); + +### start with fresh sources ### +ok( $cb->reload_indices( update_source => 0 ), + "Rebuilding trees" ); + +my $Mod = $cb->module_tree( $ModName ); +ok( $Mod, "Got module object" ); + + +### straight forward dist build - prepare, create, install +{ my $dist = CPANPLUS::Dist->new( + format => $Module, + module => $Mod + ); + + ok( $dist, "New dist object created" ); + isa_ok( $dist, 'CPANPLUS::Dist' ); + isa_ok( $dist, $Module ); + + my $status = $dist->status; + ok( $status, "Status object found" ); + isa_ok( $status, "Object::Accessor" ); + + ok( $dist->prepare, "Prepare call" ); + ok( $dist->status->prepared," Status registered OK" ); + + ok( $dist->create, "Create call" ); + ok( $dist->status->created, " Status registered OK" ); + + ok( $dist->install, "Install call" ); + ok( $dist->status->installed, + " Status registered OK" ); +} + +### check 'sanity check' option ### +{ local $CPANPLUS::Dist::_Test::Available = 0; + + ok( !$Module->format_available, + "Format availabillity turned off" ); + + { $conf->_set_build('sanity_check' => 0); + + my $dist = CPANPLUS::Dist->new( + format => $Module, + module => $Mod + ); + + ok( $dist, "Dist created with sanity check off" ); + isa_ok( $dist, $Module ); + + } + + { $conf->_set_build('sanity_check' => 1); + my $dist = CPANPLUS::Dist->new( + format => $Module, + module => $Mod + ); + + ok( !$dist, "Dist not created with sanity check on" ); + like( CPANPLUS::Error->stack_as_string, + qr/Format '$Module' is not available/, + " Error recorded as expected" ); + } +} + +### undef the status hash, make sure it complains ### +{ local $CPANPLUS::Dist::_Test::Init = 0; + + my $dist = CPANPLUS::Dist->new( + format => $Module, + module => $Mod + ); + + ok( !$dist, "No dist created by failed init" ); + like( CPANPLUS::Error->stack_as_string, + qr/Dist initialization of '$Module' failed for/s, + " Error recorded as expected" ); +} + +### test _resolve prereqs, in a somewhat simulated set of circumstances +{ my $old_prereq = $conf->get_conf('prereqs'); + + my $map = { + 0 => { + 'Previous install failed' => [ + sub { $cb->module_tree($ModPrereq)->status->installed(0); + 'install' }, + sub { like( CPANPLUS::Error->stack_as_string, + qr/failed to install before in this session/s, + " Previous install failed recorded ok" ) }, + ], + + "Set $Module->prepare to false" => [ + sub { $CPANPLUS::Dist::_Test::Prepare = 0; 'install' }, + sub { like( CPANPLUS::Error->stack_as_string, + qr/Unable to create a new distribution object/s, + " Dist creation failed recorded ok" ) }, + sub { like( CPANPLUS::Error->stack_as_string, + qr/Failed to install '$ModPrereq' as prerequisite/s, + " Dist creation failed recorded ok" ) }, + ], + + "Set $Module->create to false" => [ + sub { $CPANPLUS::Dist::_Test::Create = 0; 'install' }, + sub { like( CPANPLUS::Error->stack_as_string, + qr/Unable to create a new distribution object/s, + " Dist creation failed recorded ok" ) }, + sub { like( CPANPLUS::Error->stack_as_string, + qr/Failed to install '$ModPrereq' as prerequisite/s, + " Dist creation failed recorded ok" ) }, + ], + + "Set $Module->install to false" => [ + sub { $CPANPLUS::Dist::_Test::Install = 0; 'install' }, + sub { like( CPANPLUS::Error->stack_as_string, + qr/Failed to install '$ModPrereq' as/s, + " Dist installation failed recorded ok" ) }, + ], + + "Set dependency to be perl-core" => [ + sub { $cb->module_tree( $ModPrereq )->package( + 'perl-5.8.1.tar.gz' ); 'install' }, + sub { like( CPANPLUS::Error->stack_as_string, + qr/Prerequisite '$ModPrereq' is perl-core/s, + " Dist installation failed recorded ok" ) }, + ], + 'Simple ignore' => [ + sub { 'ignore' }, + sub { ok( !$_[0]->status->prepared, + " Module status says not prepared" ) }, + sub { ok( !$_[0]->status->created, + " Module status says not created" ) }, + sub { ok( !$_[0]->status->installed, + " Module status says not installed" ) }, + ], + 'Ignore from conf' => [ + sub { $conf->set_conf(prereqs => PREREQ_IGNORE); '' }, + sub { ok( !$_[0]->status->prepared, + " Module status says not prepared" ) }, + sub { ok( !$_[0]->status->created, + " Module status says not created" ) }, + sub { ok( !$_[0]->status->installed, + " Module status says not installed" ) }, + ### set the conf back ### + sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, + ], + }, + 1 => { + 'Simple create' => [ + sub { 'create' }, + sub { ok( $_[0]->status->prepared, + " Module status says prepared" ) }, + sub { ok( $_[0]->status->created, + " Module status says created" ) }, + sub { ok( !$_[0]->status->installed, + " Module status says not installed" ) }, + ], + 'Simple install' => [ + sub { 'install' }, + sub { ok( $_[0]->status->prepared, + " Module status says prepared" ) }, + sub { ok( $_[0]->status->created, + " Module status says created" ) }, + sub { ok( $_[0]->status->installed, + " Module status says installed" ) }, + ], + + 'Install from conf' => [ + sub { $conf->set_conf(prereqs => PREREQ_INSTALL); '' }, + sub { ok( $_[0]->status->prepared, + " Module status says prepared" ) }, + sub { ok( $_[0]->status->created, + " Module status says created" ) }, + sub { ok( $_[0]->status->installed, + " Module status says installed" ) }, + ], + 'Create from conf' => [ + sub { $conf->set_conf(prereqs => PREREQ_BUILD); '' }, + sub { ok( $_[0]->status->prepared, + " Module status says prepared" ) }, + sub { ok( $_[0]->status->created, + " Module status says created" ) }, + sub { ok( !$_[0]->status->installed, + " Module status says not installed" ) }, + ### set the conf back ### + sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, + ], + + 'Ask from conf' => [ + sub { $cb->_register_callback( + name => 'install_prerequisite', + code => sub {1} ); + $conf->set_conf(prereqs => PREREQ_ASK); '' }, + sub { ok( $_[0]->status->prepared, + " Module status says prepared" ) }, + sub { ok( $_[0]->status->created, + " Module status says created" ) }, + sub { ok( $_[0]->status->installed, + " Module status says installed" ) }, + ### set the conf back ### + sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, + + ], + + 'Ask from conf, but decline' => [ + sub { $cb->_register_callback( + name => 'install_prerequisite', + code => sub {0} ); + $conf->set_conf( prereqs => PREREQ_ASK); '' }, + sub { ok( !$_[0]->status->installed, + " Module status says not installed" ) }, + sub { like( CPANPLUS::Error->stack_as_string, + qr/Will not install prerequisite '$ModPrereq' -- Note/, + " Install skipped, recorded ok" ) }, + ### set the conf back ### + sub { $conf->set_conf(prereqs => PREREQ_INSTALL); }, + ], + + "Set recursive dependency" => [ + sub { $cb->_status->pending_prereqs({ $ModPrereq => 1 }); + 'install' }, + sub { like( CPANPLUS::Error->stack_as_string, + qr/Recursive dependency detected/, + " Recursive dependency recorded ok" ) }, + ], + + }, + }; + + for my $bool ( sort keys %$map ) { + + diag("Running ". ($bool?'success':'fail') . " tests") if @ARGV; + + my $href = $map->{$bool}; + while ( my($txt,$aref) = each %$href ) { + + ### reset everything ### + ok( $cb->reload_indices( update_source => 0 ), + "Rebuilding trees" ); + + $CPANPLUS::Dist::_Test::Available = 1; + $CPANPLUS::Dist::_Test::Prepare = 1; + $CPANPLUS::Dist::_Test::Create = 1; + $CPANPLUS::Dist::_Test::Install = 1; + + CPANPLUS::Error->flush; + $cb->_status->mk_flush; + + ### get a new dist from Text::Bastardize ### + my $dist = CPANPLUS::Dist->new( + format => $Module, + module => $cb->module_tree( $ModName ), + ); + + ### first sub returns target ### + my $sub = shift @$aref; + my $target = $sub->(); + + my $flag = $dist->_resolve_prereqs( + format => $Module, + force => 1, + target => $target, + prereqs => $Prereq ); + + is( !!$flag, !!$bool, $txt ); + + ### any extra tests ### + $_->($cb->module_tree($ModPrereq)) for @$aref; + + } + } +} + + +### prereq satisfied tests +{ my $map = { + # version regex + 0 => undef, + 1 => undef, + 2 => qr/have to resolve/, + }; + + my $mod = CPANPLUS::Module::Fake->new( + module => $$, + package => $$, + path => $$, + version => 1 ); + + ok( $mod, "Fake module created" ); + is( $mod->version, 1, " Version set correctly" ); + + my $dist = CPANPLUS::Dist->new( + format => $Module, + module => $Mod + ); + + ok( $dist, "Dist object created" ); + isa_ok( $dist, $Module ); + + + ### scope it for the locals + { local $^W; # quell sub redefined warnings; + + ### is_uptodate will need to return false for this test + local *CPANPLUS::Module::Fake::is_uptodate = sub { return }; + local *CPANPLUS::Module::Fake::is_uptodate = sub { return }; + CPANPLUS::Error->flush; + + + ### it's satisfied + while( my($ver, $re) = each %$map ) { + + my $rv = $dist->prereq_satisfied( + version => $ver, + modobj => $mod ); + + ok( 1, "Testing ver: $ver" ); + is( $rv, undef, " Return value as expected" ); + + if( $re ) { + like( CPANPLUS::Error->stack_as_string, $re, + " Error as expected" ); + } + + CPANPLUS::Error->flush; + } + } +} + + +### dist_types tests +{ can_ok( 'CPANPLUS::Dist', 'dist_types' ); + + SKIP: { + skip "You do not have Module::Pluggable installed", 2 + unless check_install( module => 'Module::Pluggable' ); + + my @types = CPANPLUS::Dist->dist_types; + ok( scalar(@types), " Dist types found" ); + ok( grep( /_Test/, @types), " Found our _Test dist type" ); + } +} +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/t/20_CPANPLUS-Dist-MM.t b/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t new file mode 100644 index 0000000000..9516cc0d50 --- /dev/null +++ b/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t @@ -0,0 +1,403 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; + +use CPANPLUS::Configure; +use CPANPLUS::Backend; +use CPANPLUS::Dist; +use CPANPLUS::Dist::MM; +use CPANPLUS::Internals::Constants; + +use Test::More 'no_plan'; +use Cwd; +use Config; +use Data::Dumper; +use File::Basename (); +use File::Spec (); + +my $conf = gimme_conf(); +my $cb = CPANPLUS::Backend->new( $conf ); +my $noperms = ($< and not $conf->get_program('sudo')) && + ($conf->get_conf('makemakerflags') or + not -w $Config{installsitelib} ); +my $File = 'Bar.pm'; +my $Verbose = @ARGV ? 1 : 0; + +#$IPC::Cmd::DEBUG = $Verbose; + +### Make sure we get the _EUMM_NOXS_ version +my $ModName = TEST_CONF_MODULE; + +### This is the module name that gets /installed/ +my $InstName = TEST_CONF_INST_MODULE; + +### don't start sending test reports now... ### +$cb->_callbacks->send_test_report( sub { 0 } ); +$conf->set_conf( cpantest => 0 ); + +### Redirect errors to file ### +local $CPANPLUS::Error::ERROR_FH = output_handle() unless $Verbose; +local $CPANPLUS::Error::MSG_FH = output_handle() unless $Verbose; +*STDERR = output_handle() unless $Verbose; + +### dont uncomment this, it screws up where STDOUT goes and makes +### test::harness create test counter mismatches +#*STDOUT = output_handle() unless @ARGV; +### for the same test-output counter mismatch, we disable verbose +### mode +$conf->set_conf( verbose => $Verbose ); +$conf->set_conf( allow_build_interactivity => 0 ); + +### start with fresh sources ### +ok( $cb->reload_indices( update_source => 0 ), + "Rebuilding trees" ); + +### we might need this Some Day when we're going to install into +### our own sandbox dir.. but for now, no dice due to EU::I bug +# $conf->set_program( sudo => '' ); +# $conf->set_conf( makemakerflags => TEST_INSTALL_EU_MM_FLAGS ); + +### set alternate install dir ### +### XXX rather pointless, since we can't uninstall them, due to a bug +### in EU::Installed (6871). And therefor we can't test uninstall() or any of +### the EU::Installed functions. So, let's just install into sitelib... =/ +#my $prefix = File::Spec->rel2abs( File::Spec->catdir(cwd(),'dummy-perl') ); +#my $rv = $cb->configure_object->set_conf( makemakerflags => "PREFIX=$prefix" ); +#ok( $rv, "Alternate install path set" ); + +my $Mod = $cb->module_tree( $ModName ); +my $InstMod = $cb->module_tree( $InstName ); +ok( $Mod, "Loaded object for: " . $Mod->name ); +ok( $Mod, "Loaded object for: " . $InstMod->name ); + +### format_available tests ### +{ ok( CPANPLUS::Dist::MM->format_available, + "Format is available" ); + + ### whitebox test! + { local $^W; + local *CPANPLUS::Dist::MM::can_load = sub { 0 }; + ok(!CPANPLUS::Dist::MM->format_available, + " Making format unavailable" ); + } + + ### test if the error got logged ok ### + like( CPANPLUS::Error->stack_as_string, + qr/You do not have .+?'CPANPLUS::Dist::MM' not available/s, + " Format failure logged" ); + + ### flush the stack ### + CPANPLUS::Error->flush; +} + +ok( $Mod->fetch, "Fetching module to ".$Mod->status->fetch ); +ok( $Mod->extract, "Extracting module to ".$Mod->status->extract ); + +ok( $Mod->test, "Testing module" ); + +ok( $Mod->status->dist_cpan->status->test, + " Test success registered as status" ); +ok( $Mod->status->dist_cpan->status->prepared, + " Prepared status registered" ); +ok( $Mod->status->dist_cpan->status->created, + " Created status registered" ); +is( $Mod->status->dist_cpan->status->distdir, $Mod->status->extract, + " Distdir status registered properly" ); + +### test the convenience methods +ok( $Mod->prepare, "Preparing module" ); +ok( $Mod->create, "Creating module" ); + +ok( $Mod->dist, "Building distribution" ); +ok( $Mod->status->dist_cpan, " Dist registered as status" ); +isa_ok( $Mod->status->dist_cpan, "CPANPLUS::Dist::MM" ); + +### flush the lib cache +### otherwise, cpanplus thinks the module's already installed +### since the blib is already in @INC +$cb->_flush( list => [qw|lib|] ); + +SKIP: { + + skip(q[No install tests under core perl], 10) if $ENV{PERL_CORE}; + + skip(q[Probably no permissions to install, skipping], 10) + if $noperms; + + ### XXX new EU::I should be forthcoming pending this patch from Steffen + ### Mueller on p5p: http://www.xray.mpe.mpg.de/mailing-lists/ \ + ### perl5-porters/2007-01/msg00895.html + ### This should become EU::I 1.42.. if so, we should upgrade this bit of + ### code and remove the diag, since we can then install in our dummy dir.. + diag("\nSorry, installing into your real perl dir, rather than our test"); + diag("area since ExtUtils::Installed does not probe for .packlists in " ); + diag('other dirs than those in %Config. See bug #6871 on rt.cpan.org ' ); + diag('for details'); + + diag(q[Note: 'sudo' might ask for your password to do the install test]) + if $conf->get_program('sudo'); + + ok( $Mod->install( force =>1 ), + "Installing module" ); + ok( $Mod->status->installed," Module installed according to status" ); + + + SKIP: { ### EU::Installed tests ### + + skip("makemakerflags set -- probably EU::Installed tests will fail", 8) + if $conf->get_conf('makemakerflags'); + + skip( "Old perl on cygwin detected " . + "-- tests will fail due to known bugs", 8 + ) if ON_OLD_CYGWIN; + + ### might need it Later when EU::I is fixed.. + #local @INC = ( TEST_INSTALL_DIR_LIB, @INC ); + + { ### validate + my @missing = $InstMod->validate; + + is_deeply( \@missing, [], + "No missing files" ); + } + + { ### files + my @files = $InstMod->files; + + ### number of files may vary from OS to OS + ok( scalar(@files), "All files accounted for" ); + ok( grep( /$File/, @files), + " Found the module" ); + + ### XXX does this work on all OSs? + #ok( grep( /man/, @files ), + # " Found the manpage" ); + } + + { ### packlist + my ($obj) = $InstMod->packlist; + isa_ok( $obj, "ExtUtils::Packlist" ); + } + + { ### directory_tree + my @dirs = $InstMod->directory_tree; + ok( scalar(@dirs), "Directory tree obtained" ); + + my $found; + for my $dir (@dirs) { + ok( -d $dir, " Directory exists" ); + + my $file = File::Spec->catfile( $dir, $File ); + $found = $file if -e $file; + } + + ok( -e $found, " Module found" ); + } + + SKIP: { + skip("Probably no permissions to uninstall", 1) + if $noperms; + + ok( $InstMod->uninstall,"Uninstalling module" ); + } + } +} + +### test exceptions in Dist::MM->create ### +{ ok( $Mod->status->mk_flush, "Old status info flushed" ); + my $dist = CPANPLUS::Dist->new( module => $Mod, + format => INSTALLER_MM ); + + ok( $dist, "New dist object made" ); + ok(!$dist->prepare, " Dist->prepare failed" ); + like( CPANPLUS::Error->stack_as_string, qr/No dir found to operate on/, + " Failure logged" ); + + ### manually set the extract dir, + $Mod->status->extract($0); + + ok(!$dist->create, " Dist->create failed" ); + like( CPANPLUS::Error->stack_as_string, qr/not successfully prepared/s, + " Failure logged" ); + + ### pretend we've been prepared ### + $dist->status->prepared(1); + + ok(!$dist->create, " Dist->create failed" ); + like( CPANPLUS::Error->stack_as_string, qr/Could not chdir/s, + " Failure logged" ); +} + +### writemakefile.pl tests ### +{ ### remove old status info + ok( $Mod->status->mk_flush, "Old status info flushed" ); + ok( $Mod->fetch, "Module fetched again" ); + ok( $Mod->extract, "Module extracted again" ); + + ### cheat and add fake prereqs ### + my $prereq = TEST_CONF_PREREQ; + + $Mod->status->prereqs( { $prereq => 0 } ); + + my $makefile_pl = MAKEFILE_PL->( $Mod->status->extract ); + my $makefile = MAKEFILE->( $Mod->status->extract ); + + my $dist = $Mod->dist; + ok( $dist, "Dist object built" ); + + ### check for a makefile.pl and 'write' one + ok( -s $makefile_pl, " Makefile.PL present" ); + ok( $dist->write_makefile_pl( force => 0 ), + " Makefile.PL written" ); + like( CPANPLUS::Error->stack_as_string, qr/Already created/, + " Prior existance noted" ); + + ### ok, unlink the makefile.pl, now really write one + unlink $makefile; + + ok( unlink($makefile_pl), "Deleting Makefile.PL"); + ok( !-s $makefile_pl, " Makefile.PL deleted" ); + ok( !-s $makefile, " Makefile deleted" ); + ok($dist->write_makefile_pl," Makefile.PL written" ); + + ### see if we wrote anything sensible + my $fh = OPEN_FILE->( $makefile_pl ); + ok( $fh, "Makefile.PL open for read" ); + + my $str = do { local $/; <$fh> }; + like( $str, qr/### Auto-generated .+ by CPANPLUS ###/, + " Autogeneration noted" ); + like( $str, '/'. $Mod->module .'/', + " Contains module name" ); + like( $str, '/'. quotemeta($Mod->version) . '/', + " Contains version" ); + like( $str, '/'. $Mod->author->author .'/', + " Contains author" ); + like( $str, '/PREREQ_PM/', " Contains prereqs" ); + like( $str, qr/$prereq.+0/, " Contains prereqs" ); + + close $fh; + + ### seems ok, now delete it again and go via install() + ### to see if it picks up on the missing makefile.pl and + ### does the right thing + ok( unlink($makefile_pl), "Deleting Makefile.PL"); + ok( !-s $makefile_pl, " Makefile.PL deleted" ); + ok( $dist->status->mk_flush,"Dist status flushed" ); + ok( $dist->prepare, " Dist->prepare run again" ); + ok( $dist->create, " Dist->create run again" ); + ok( -s $makefile_pl, " Makefile.PL present" ); + like( CPANPLUS::Error->stack_as_string, + qr/attempting to generate one/, + " Makefile.PL generation attempt logged" ); + + ### now let's throw away the makefile.pl, flush the status and not + ### write a makefile.pl + { local $^W; + local *CPANPLUS::Dist::MM::write_makefile_pl = sub { 1 }; + + unlink $makefile_pl; + unlink $makefile; + + ok(!-s $makefile_pl, "Makefile.PL deleted" ); + ok(!-s $makefile, "Makefile deleted" ); + ok( $dist->status->mk_flush,"Dist status flushed" ); + ok(!$dist->prepare, " Dist->prepare failed" ); + like( CPANPLUS::Error->stack_as_string, + qr/Could not find 'Makefile.PL'/i, + " Missing Makefile.PL noted" ); + is( $dist->status->makefile, 0, + " Did not manage to create Makefile" ); + } + + ### now let's write a makefile.pl that just does 'die' + { local $^W; + local *CPANPLUS::Dist::MM::write_makefile_pl = + __PACKAGE__->_custom_makefile_pl_sub( "exit 1;" ); + + ### there's no makefile.pl now, since the previous test failed + ### to create one + #ok( -e $makefile_pl, "Makefile.PL exists" ); + #ok( unlink($makefile_pl), " Deleting Makefile.PL"); + ok(!-s $makefile_pl, "Makefile.PL deleted" ); + ok( $dist->status->mk_flush,"Dist status flushed" ); + ok(!$dist->prepare, " Dist->prepare failed" ); + like( CPANPLUS::Error->stack_as_string, qr/Could not run/s, + " Logged failed 'perl Makefile.PL'" ); + is( $dist->status->makefile, 0, + " Did not manage to create Makefile" ); + } + + ### clean up afterwards ### + ok( unlink($makefile_pl), "Deleting Makefile.PL"); + $dist->status->mk_flush; + +} + +### test ENV setting in Makefile.PL +{ ### use print() not die() -- we're redirecting STDERR in tests! + my $env = ENV_CPANPLUS_IS_EXECUTING; + my $sub = __PACKAGE__->_custom_makefile_pl_sub( + "print qq[ENV=\$ENV{$env}\n]; exit 1;" ); + + my $clone = $Mod->clone; + $clone->status->fetch( $Mod->status->fetch ); + + ok( $clone, 'Testing ENV settings $dist->prepare' ); + ok( $clone->extract, ' Files extracted' ); + ok( $clone->prepare, ' $mod->prepare worked first time' ); + + my $dist = $clone->status->dist; + my $makefile_pl = MAKEFILE_PL->( $clone->status->extract ); + + ok( $sub->($dist), " Custom Makefile.PL written" ); + ok( -e $makefile_pl, " File exists" ); + + ### clear errors + CPANPLUS::Error->flush; + + my $rv = $dist->prepare( force => 1, verbose => 0 ); + ok( !$rv, ' $dist->prepare failed' ); + + SKIP: { + skip( "Can't test ENV{$env} -- no buffers available", 1 ) + unless IPC::Cmd->can_capture_buffer; + + my $re = quotemeta( $makefile_pl ); + like( CPANPLUS::Error->stack_as_string, qr/ENV=$re/, + " \$ENV $env set correctly during execution"); + } + + ### and the ENV var should no longer be set now + ok( !$ENV{$env}, " ENV var now unset" ); +} + +sub _custom_makefile_pl_sub { + my $pkg = shift; + my $txt = shift or return; + + return sub { + my $dist = shift; + my $self = $dist->parent; + my $fh = OPEN_FILE->( + MAKEFILE_PL->($self->status->extract), '>' ); + print $fh $txt; + close $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/t/21_CPANPLUS-Dist-No-Build.t b/lib/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t new file mode 100644 index 0000000000..c4d1b5a00b --- /dev/null +++ b/lib/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t @@ -0,0 +1,57 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; +use Test::More 'no_plan'; + +use CPANPLUS::Dist; +use CPANPLUS::Backend; +use CPANPLUS::Module::Fake; +use CPANPLUS::Module::Author::Fake; +use CPANPLUS::Internals::Constants; + +my $Conf = gimme_conf(); +my $CB = CPANPLUS::Backend->new( $Conf ); + +### set the config so that we will ignore the build installer, +### but prefer it anyway +{ CPANPLUS::Dist->_ignore_dist_types( INSTALLER_BUILD ); + $Conf->set_conf( prefer_makefile => 0 ); +} + +my $Mod = $CB->module_tree( 'Foo::Bar::MB::NOXS' ); + +ok( $Mod, "Module object retrieved" ); +ok( not grep { $_ eq INSTALLER_BUILD } CPANPLUS::Dist->dist_types, + " Build installer not returned" ); + +### fetch the file first +{ my $where = $Mod->fetch; + ok( -e $where, " Tarball '$where' exists" ); +} + +### extract it, silence warnings/messages +{ local $CPANPLUS::Error::MSG_FH = output_handle(); + local $CPANPLUS::Error::ERROR_FH = output_handle(); + + my $where = $Mod->extract; + ok( -e $where, " Tarball extracted to '$where'" ); +} + +### check the installer type +{ is( $Mod->status->installer_type, INSTALLER_MM, + "Proper installer type found" ); + + my $err = CPANPLUS::Error->stack_as_string; + like( $err, '/'.INSTALLER_MM.'/', + " Error mentions " . INSTALLER_MM ); + like( $err, '/'.INSTALLER_BUILD.'/', + " Error mentions " . INSTALLER_BUILD ); + like( $err, qr/but might not be able to install/, + " Error mentions install warning" ); +} + +END { 1 while unlink output_file() } diff --git a/lib/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t b/lib/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t new file mode 100644 index 0000000000..79df1dfdad --- /dev/null +++ b/lib/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t @@ -0,0 +1,122 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; + +use CPANPLUS::Backend; +use Test::More 'no_plan'; +use Data::Dumper; + +my $conf = gimme_conf(); +$conf->set_conf( verbose => 0 ); + +my $Class = 'CPANPLUS::Selfupdate'; +my $ModClass = "CPANPLUS::Selfupdate::Module"; +my $CB = CPANPLUS::Backend->new( $conf ); +my $Acc = 'selfupdate_object'; +my $Conf = $Class->_get_config; +my $Dep = TEST_CONF_PREREQ; # has to be in our package file && core! +my $Feat = 'some_feature'; +my $Prereq = { $Dep => 0 }; + +### test the object +{ ok( $CB, "New backend object created" ); + can_ok( $CB, $Acc ); + + ok( $Conf, "Got configuration hash" ); + + my $su = $CB->$Acc; + ok( $su, "Selfupdate object retrieved" ); + isa_ok( $su, $Class ); +} + +### test the feature list +{ ### start with defining our OWN type of config, as not all mentioned + ### modules will be present in our bundled package files. + ### XXX WHITEBOX TEST!!!! + { delete $Conf->{$_} for keys %$Conf; + $Conf->{'dependencies'} = $Prereq; + $Conf->{'core'} = $Prereq; + $Conf->{'features'}->{$Feat} = [ $Prereq, sub { 1 } ]; + } + + is_deeply( $Conf, $Class->_get_config, + "Config updated succesfully" ); + + my @feat = $CB->$Acc->list_features; + ok( scalar(@feat), "Features list returned" ); + + ### test if we get modules for each feature + for my $feat (@feat) { + my $meth = 'modules_for_feature'; + my @mods = $CB->$Acc->$meth( $feat ); + + ok( $feat, "Testing feature '$feat'" ); + ok( scalar( @mods ), " Module list returned" ); + + my $acc = 'is_installed_version_sufficient'; + for my $mod (@mods) { + isa_ok( $mod, "CPANPLUS::Module" ); + isa_ok( $mod, $ModClass ); + can_ok( $mod, $acc ); + ok( $mod->$acc, " Module uptodate" ); + } + + ### check if we can get a hashref + { my $href = $CB->$Acc->$meth( $feat, 1 ); + ok( $href, "Got result as hash" ); + isa_ok( $href, 'HASH' ); + is_deeply( $href, $Prereq, + " With the proper entries" ); + + } + + } + + ### find enabled features + { my $meth = 'list_enabled_features'; + can_ok( $Class, $meth ); + + my @list = $CB->$Acc->$meth; + ok( scalar(@list), "Retrieved enabled features" ); + is_deeply( [$Feat], \@list, + " Proper features found" ); + } + + ### find dependencies/core modules + for my $meth ( qw[list_core_dependencies list_core_modules] ) { + can_ok( $Class, $meth ); + + my @list = $CB->$Acc->$meth; + ok( scalar(@list), "Retrieved modules" ); + is( scalar(@list), 1, " 1 Found" ); + isa_ok( $list[0], $ModClass ); + is( $list[0]->name, $Dep, + " Correct module found" ); + + ### check if we can get a hashref + { my $href = $CB->$Acc->$meth( 1 ); + ok( $href, "Got result as hash" ); + isa_ok( $href, 'HASH' ); + is_deeply( $href, $Prereq, + " With the proper entries" ); + } + } + + ### now selfupdate ourselves + { ### XXX just test the mechanics, make sure install returns true + ### declare twice because warnings are hateful + ### declare in a block to quelch 'sub redefined' warnings. + { local *CPANPLUS::Selfupdate::Module::install = sub { 1 }; } + local *CPANPLUS::Selfupdate::Module::install = sub { 1 }; + + my $meth = 'selfupdate'; + can_ok( $Class, $meth ); + ok( $CB->$Acc->$meth( update => 'all'), + " Selfupdate successful" ); + } +} + diff --git a/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t b/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t new file mode 100644 index 0000000000..b028404085 --- /dev/null +++ b/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t @@ -0,0 +1,469 @@ +### make sure we can find our conf.pl file +BEGIN { + use FindBin; + require "$FindBin::Bin/inc/conf.pl"; +} + +use strict; +use CPANPLUS::Backend; +use CPANPLUS::Internals::Constants::Report; + +my $send_tests = 55; +my $query_tests = 8; +my $total_tests = $send_tests + $query_tests; + +use Test::More 'no_plan'; +use Module::Load::Conditional qw[can_load]; + +use FileHandle; +use Data::Dumper; + +use constant NOBODY => 'nobody@xs4all.nl'; + +my $conf = gimme_conf(); +my $CB = CPANPLUS::Backend->new( $conf ); +my $ModName = TEST_CONF_MODULE; +my $ModPrereq = TEST_CONF_PREREQ; +my $Mod = $CB->module_tree($ModName); +my $int_ver = $CPANPLUS::Internals::VERSION; + +### explicitly enable testing if possible ### +$CB->configure_object->set_conf(cpantest =>1) if $ARGV[0]; + +my $map = { + all_ok => { + buffer => '', # output from build process + failed => 0, # indicate failure + match => [qw|/PASS/|], # list of regexes for the output + check => 0, # check if callbacks got called? + }, + skipped_test => { + buffer => '', + failed => 0, + match => ['/PASS/', + '/tests for this module were skipped during this build/', + ], + check => 0, + skiptests + => 1, # did we skip the tests? + }, + missing_prereq => { + buffer => missing_prereq_buffer(), + failed => 1, + match => ['/The comments above are created mechanically/', + '/computer-generated error report/', + '/Below is the error stack from stage/', + '/test suite seem to fail without these modules/', + '/floo/', + '/FAIL/', + '/make test/', + ], + check => 1, + }, + missing_tests => { + buffer => missing_tests_buffer(), + failed => 1, + match => ['/The comments above are created mechanically/', + '/computer-generated error report/', + '/Below is the error stack from stage/', + '/RECOMMENDATIONS/', + '/UNKNOWN/', + '/make test/', + ], + check => 0, + }, + perl_version_too_low_mm => { + buffer => perl_version_too_low_buffer_mm(), + failed => 1, + match => ['/This distribution has been tested/', + '/http://testers.cpan.org/', + '/NA/', + ], + check => 0, + }, + perl_version_too_low_build1 => { + buffer => perl_version_too_low_buffer_build(1), + failed => 1, + match => ['/This distribution has been tested/', + '/http://testers.cpan.org/', + '/NA/', + ], + check => 0, + }, + perl_version_too_low_build2 => { + buffer => perl_version_too_low_buffer_build(2), + failed => 1, + match => ['/This distribution has been tested/', + '/http://testers.cpan.org/', + '/NA/', + ], + check => 0, + }, + prereq_versions_too_low => { + ### set the prereq version incredibly high + pre_hook => sub { + my $mod = shift; + my $clone = $mod->clone; + $clone->status->prereqs( { $ModPrereq => ~0 } ); + return $clone; + }, + failed => 1, + match => ['/This distribution has been tested/', + '/http://testers.cpan.org/', + '/NA/', + ], + check => 0, + }, + prereq_not_on_cpan => { + pre_hook => sub { + my $mod = shift; + my $clone = $mod->clone; + $clone->status->prereqs( + { TEST_CONF_INVALID_MODULE, 0 } + ); + return $clone; + }, + failed => 1, + match => ['/This distribution has been tested/', + '/http://testers.cpan.org/', + '/NA/', + ], + check => 0, + }, + + + +}; + +### test config settings +{ for my $opt ( qw[cpantest cpantest_mx] ) { + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= "@_" }; + + my $org = $conf->get_conf( $opt ); + ok( $conf->set_conf( $opt => $$ ), + "Setting option $opt to $$" ); + is( $conf->get_conf( $opt ), $$, + " Retrieved properly" ); + ok( $conf->set_conf( $opt => $org ), + " Option $opt set back to original" ); + ok( !$warnings, " No warnings" ); + } +} + +### test constants ### +{ { my $to = CPAN_MAIL_ACCOUNT->('foo'); + is( $to, 'foo@cpan.org', "Got proper mail account" ); + } + + { ok(RELEVANT_TEST_RESULT->($Mod),"Test is relevant" ); + + ### test non-relevant tests ### + my $cp = $Mod->clone; + $cp->module( $Mod->module . '::' . ($^O eq 'beos' ? 'MSDOS' : 'Be') ); + ok(!RELEVANT_TEST_RESULT->($cp),"Test is irrelevant"); + } + + { my $support = "it works!"; + my @support = ( "No support for OS", + "OS unsupported", + "os unsupported", + ); + ok(!UNSUPPORTED_OS->($support), "OS supported"); + ok( UNSUPPORTED_OS->($_), "OS not supported") for(@support); + } + + { ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_mm() ), + "Perl version too low" ); + ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_build(1) ), + "Perl version too low" ); + ok(PERL_VERSION_TOO_LOW->( perl_version_too_low_buffer_build(2) ), + "Perl version too low" ); + ok(!PERL_VERSION_TOO_LOW->('foo'), + " Perl version adequate" ); + } + + { my $tests = "test.pl"; + my @none = ( "No tests defined for Foo extension.", + "'No tests defined for Foo::Bar extension.'", + "'No tests defined.'", + ); + ok(!NO_TESTS_DEFINED->($tests), "Tests defined"); + ok( NO_TESTS_DEFINED->($_), "No tests defined") for(@none); + } + + { my $fail = 'MAKE TEST'; my $unknown = 'foo'; + is( TEST_FAIL_STAGE->($fail), lc $fail, + "Proper test fail stage found" ); + is( TEST_FAIL_STAGE->($unknown), 'fetch', + "Proper test fail stage found" ); + } + + ### test missing prereqs + { my $str = q[Can't locate Foo/Bar.pm in @INC]; + + ### standard test + { my @list = MISSING_PREREQS_LIST->( $str ); + is( scalar(@list), 1, " List of missing prereqs found" ); + is( $list[0], 'Foo::Bar', " Proper prereq found" ); + } + + ### multiple mentions of same prereq + { my @list = MISSING_PREREQS_LIST->( $str . $str ); + + is( scalar(@list), 1, " 1 result for multiple mentions" ); + is( $list[0], 'Foo::Bar', " Proper prereq found" ); + } + } + + { # cp version, author + my $header = REPORT_MESSAGE_HEADER->($int_ver,'foo'); + ok( $header, "Test header generated" ); + like( $header, qr/Dear foo,/, " Proper content found" ); + like( $header, qr/puter-gen/, " Proper content found" ); + like( $header, qr/CPANPLUS,/, " Proper content found" ); + like( $header, qr/ments may/, " Proper content found" ); + } + + { # stage, buffer + my $header = REPORT_MESSAGE_FAIL_HEADER->('test','buffer'); + ok( $header, "Test header generated" ); + like( $header, qr/uploading/, " Proper content found" ); + like( $header, qr/RESULTS:/, " Proper content found" ); + like( $header, qr/stack/, " Proper content found" ); + like( $header, qr/buffer/, " Proper content found" ); + } + + { my $prereqs = REPORT_MISSING_PREREQS->('foo','bar@example.com','Foo::Bar'); + ok( $prereqs, "Test output generated" ); + like( $prereqs, qr/'foo \(bar\@example\.com\)'/, + " Proper content found" ); + like( $prereqs, qr/Foo::Bar/, " Proper content found" ); + like( $prereqs, qr/prerequisi/, " Proper content found" ); + like( $prereqs, qr/PREREQ_PM/, " Proper content found" ); + } + + { my $prereqs = REPORT_MISSING_PREREQS->(undef,undef,'Foo::Bar'); + ok( $prereqs, "Test output generated" ); + like( $prereqs, qr/Your Name/, " Proper content found" ); + like( $prereqs, qr/Foo::Bar/, " Proper content found" ); + like( $prereqs, qr/prerequisi/, " Proper content found" ); + like( $prereqs, qr/PREREQ_PM/, " Proper content found" ); + } + + { my $missing = REPORT_MISSING_TESTS->(); + ok( $missing, "Missing test string generated" ); + like( $missing, qr/tests/, " Proper content found" ); + like( $missing, qr/Test::More/, " Proper content found" ); + } + + { my $missing = REPORT_MESSAGE_FOOTER->(); + ok( $missing, "Message footer string generated" ); + like( $missing, qr/NOTE/, " Proper content found" ); + like( $missing, qr/identical/, " Proper content found" ); + like( $missing, qr/mistaken/, " Proper content found" ); + like( $missing, qr/appreciate/, " Proper content found" ); + like( $missing, qr/Additional/, " Proper content found" ); + } + + { my @libs = MISSING_EXTLIBS_LIST->("No library found for -lfoo\nNo library found for -lbar"); + ok( @libs, "Missing external libraries found" ); + my @list = qw(foo bar); + is_deeply( \@libs, \@list, " Proper content found" ); + } + + { my $clone = $Mod->clone; + my $prereqs = { $ModPrereq => ~0 }; + + $clone->status->prereqs( $prereqs ); + + my $str = REPORT_LOADED_PREREQS->( $clone ); + + like($str, qr/PREREQUISITES:/, "Listed loaded prerequisites" ); + like($str, qr/\! $ModPrereq\s+\S+\s+\S+/, + " Proper content found" ); + } +} + +### callback tests +{ ### as reported in bug 13086, this callback returned the wrong item + ### from the list: + ### $self->_callbacks->munge_test_report->($Mod, $message, $grade); + my $rv = $CB->_callbacks->munge_test_report->( 1..4 ); + is( $rv, 2, "Default 'munge_test_report' callback OK" ); +} + + +### test creating test reports ### +SKIP: { + skip "You have chosen not to enable test reporting", $total_tests, + unless $CB->configure_object->get_conf('cpantest'); + + skip "No report send & query modules installed", $total_tests + unless $CB->_have_query_report_modules(verbose => 0); + + + SKIP: { + my $mod = $CB->module_tree( TEST_CONF_PREREQ ); # is released to CPAN + ok( $mod, "Module retrieved" ); + + ### so we're not pinned down to this specific version of perl + my @list = $mod->fetch_report( all_versions => 1 ); + skip "Possibly no net connection, or server down", 7 unless @list; + + my $href = $list[0]; + ok( scalar(@list), "Fetched test report" ); + is( ref $href, ref {}, " Return value has hashrefs" ); + + ok( $href->{grade}, " Has a grade" ); + + ### XXX use constants for grades? + like( $href->{grade}, qr/pass|fail|unknown|na/i, + " Grade as expected" ); + + my $pkg_name = $mod->package_name; + ok( $href->{dist}, " Has a dist" ); + like( $href->{dist}, qr/$pkg_name/, " Dist as expected" ); + + ok( $href->{platform}, " Has a platform" ); + } + + skip "No report sending modules installed", $send_tests + unless $CB->_have_send_report_modules(verbose => 0); + + for my $type ( keys %$map ) { + + + ### never enter the editor for test reports + ### but check if the callback actually gets called; + my $called_edit; my $called_send; + $CB->_register_callback( + name => 'edit_test_report', + code => sub { $called_edit++; 0 } + ); + + $CB->_register_callback( + name => 'send_test_report', + code => sub { $called_send++; 1 } + ); + + ### reset from earlier tests + $CB->_register_callback( + name => 'munge_test_report', + code => sub { return $_[1] } + ); + + my $mod = $map->{$type}->{'pre_hook'} + ? $map->{$type}->{'pre_hook'}->( $Mod ) + : $Mod; + + my $file = $CB->_send_report( + module => $mod, + buffer => $map->{$type}{'buffer'}, + failed => $map->{$type}{'failed'}, + tests_skipped => ($map->{$type}{'skiptests'} ? 1 : 0), + save => 1, + dontcc => 1, # no need to send, and also skips + # fetching reports from testers.cpan + ); + + ok( $file, "Type '$type' written to file" ); + ok( -e $file, " File exists" ); + + my $fh = FileHandle->new($file); + ok( $fh, " Opened file for reading" ); + + my $in = do { local $/; <$fh> }; + ok( $in, " File has contents" ); + + for my $regex ( @{$map->{$type}->{match}} ) { + like( $in, $regex, " File contains expected contents" ); + } + + ### check if our registered callback got called ### + if( $map->{$type}->{check} ) { + ok( $called_edit, " Callback to edit was called" ); + ok( $called_send, " Callback to send was called" ); + } + + #unlink $file; + + +### T::R tests don't even try to mail, let's not try and be smarter +### ourselves +# { ### use a dummy 'editor' and see if the editor +# ### invocation doesn't break things +# $conf->set_program( editor => "$^X -le1" ); +# $CB->_callbacks->edit_test_report( sub { 1 } ); +# +# ### XXX whitebox test!!! Might change =/ +# ### this makes test::reporter not ask for what editor to use +# ### XXX stupid lousy perl warnings; +# local $Test::Reporter::MacApp = 1; +# local $Test::Reporter::MacApp = 1; +# +# ### now try and mail the report to a /dev/null'd mailbox +# my $ok = $CB->_send_report( +# module => $Mod, +# buffer => $map->{$type}->{'buffer'}, +# failed => $map->{$type}->{'failed'}, +# address => NOBODY, +# dontcc => 1, +# ); +# ok( $ok, " Mailed report to NOBODY" ); +# } + } +} + + +sub missing_prereq_buffer { + return q[ +MAKE TEST: +Can't locate floo.pm in @INC (@INC contains: /Users/kane/sources/p4/other/archive-extract/lib /Users/kane/sources/p4/other/file-fetch/lib /Users/kane/sources/p4/other/archive-tar-new/lib /Users/kane/sources/p4/other/carp-trace/lib /Users/kane/sources/p4/other/log-message/lib /Users/kane/sources/p4/other/module-load/lib /Users/kane/sources/p4/other/params-check/lib /Users/kane/sources/p4/other/qmail-checkpassword/lib /Users/kane/sources/p4/other/module-load-conditional/lib /Users/kane/sources/p4/other/term-ui/lib /Users/kane/sources/p4/other/ipc-cmd/lib /Users/kane/sources/p4/other/config-auto/lib /Users/kane/sources/NSA /Users/kane/sources/NSA/misc /Users/kane/sources/NSA/test /Users/kane/sources/beheer/perl /opt/lib/perl5/5.8.3/darwin-2level /opt/lib/perl5/5.8.3 /opt/lib/perl5/site_perl/5.8.3/darwin-2level /opt/lib/perl5/site_perl/5.8.3 /opt/lib/perl5/site_perl .). +BEGIN failed--compilation aborted. + ]; +} + +sub missing_tests_buffer { + return q[ +cp lib/Acme/POE/Knee.pm blib/lib/Acme/POE/Knee.pm +cp demo_race.pl blib/lib/Acme/POE/demo_race.pl +cp demo_simple.pl blib/lib/Acme/POE/demo_simple.pl +MAKE TEST: +No tests defined for Acme::POE::Knee extension. + ]; +} + +sub perl_version_too_low_buffer_mm { + return q[ +Running [/usr/bin/perl5.8.1 Makefile.PL ]... +Perl v5.8.3 required--this is only v5.8.1, stopped at Makefile.PL line 1. +BEGIN failed--compilation aborted at Makefile.PL line 1. +[ERROR] Could not run '/usr/bin/perl5.8.1 Makefile.PL': Perl v5.8.3 required--this is only v5.8.1, stopped at Makefile.PL line 1. +BEGIN failed--compilation aborted at Makefile.PL line 1. + -- cannot continue + ]; +} + +sub perl_version_too_low_buffer_build { + my $type = shift; + return q[ +ERROR: perl: Version 5.006001 is installed, but we need version >= 5.008001 +ERROR: version: Prerequisite version isn't installed +ERRORS/WARNINGS FOUND IN PREREQUISITES. You may wish to install the versions + of the modules indicated above before proceeding with this installation. + ] if($type == 1); + return q[ +ERROR: Version 5.006001 of perl is installed, but we need version >= 5.008001 +ERROR: version: Prerequisite version isn't installed +ERRORS/WARNINGS FOUND IN PREREQUISITES. You may wish to install the versions + of the modules indicated above before proceeding with this installation. + ] if($type == 2); +} + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed new file mode 100644 index 0000000000..7606c3b7e5 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed @@ -0,0 +1,19 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed + +Created at Sat Apr 7 13:06:48 2007 +######################################################################### +__UU__ +M'XL("%_EO$4``S`Q;6%I;')C+G1X=`!+S,E,+%9P#8T(5@`#)=>*DM"2S)QB +M*RO?Q.Q4$"Y2`$HZYZ>D*M@D%R3F%>24%CND5B3F%N2DZB7GY]HI<25"#?'S +MAQB#U1"_?"+-\76".\8W/Z4T)]7*RJDT,R>%:.UP9Z!J]_,G:`(`W)]=R`X! +"```` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000000..20d4cb2fda --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,34 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed + +Created at Sat Apr 7 13:06:48 2007 +######################################################################### +__UU__ +M'XL("!1%OT4"`T)U;F1L92U&;V\M0F%R+3`N,#$N=&%R`.V7:V_:,!2&^8I_ +MQ6F91"L52"`)6KI6`Q8TI`$5EZW2-"%##%C-K8FSEDW[[W,2:&E$6VGKH$Q^ +M(`KR<4YB7K_'3CUT3(L4FJY;J&._(!4EN91Y821.5563LY:<.:MS_%N65+6J +M*67^R4BR(E<J&5`S6R`,&/8!,E?8(4_UNYD38CTSR+5!9?:$^@;]+3HN[5C_ +MJB0+_7>I?])>VI'^FBR7A?ZO0'_>7MJ%_EI%%?J_$OUY>]&S_U)_35$>U5^5 +MM'O]I2K7OQK7?TGH_\_Q\.0*SP@D>NLZ%US7N>*G"+WY;/3ZK6X'SN`PFA>' +MO$WFQVAD=#Z,1@B=S0DV9>C4V@9"Z01P%V]T.P.C,^@CM(KINC'4]<L^<*+, +MZ4BG&\72D7;]L6NBR/HUC1L3TB21Y2/5AH./W1Y"QBT;,FH%/`6^(M'A0\<% +MGJGAF@3>33SL>%88O">WV/8L4IRX]CG/,@D9']_]/Y'96S;Y/_H?II2/]N+3 +MBZW_3_I?45?^E\OE<KS^2XKP_W:&3V"#"TY1%`B83R>,6_Z+3QE930LX0I&A +M(MNO&^SL'/+I(I`_B;LN"\FHV>NV5UTW+C+Y$\C!E#IF`*OJ$R<P:<!2]_K) +MZTK[HF?T^W&ZV0_J0>'ME&?H#YO-UN6R-0^_DF=(+/_P<?_(_GQ,V5J]/^C5 +M&H.U9-=?TX/_=H*.3Z,HVC?_USJMIM$?O.3[WU/^+\O5U/Y/+6O"_UMAHPW1 +MV@J`5K,AF\T.YC0`*_*B.X4H'J"V,:@5%[8%S]%VS9#7#ILP7#`QPW"$39.8 +M,%[`G?F.]W@A_9_6_Z6FV_*_4DV__ZF*I`K_;X,<S!GS]%+)COU9&(?4,HN! +M&_H3,G7]&2DZA,4SHA!X9%*<,]M"N<L$B`L"_V+P?)>Y;.&1@X,#@!:#&VI9 +M,)ECA[]<4`?8G,`T9*$?=XBOSB$'VT2_JQ`/IR+Z3OR`NHZ^MGU?-HVFOFOK +ML+ET48<+:EDF]0-^:<#W+<@GUR'U2:`C%&TD?#H.690F>EP=DH&C&7&(CQDQ +H1^.%OFE+!,N[@U:L2*)0"00"@4`@$`@$`H%`(-@;?@-?EF['`"@````` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/CHECKSUMS new file mode 100644 index 0000000000..e716d3635c --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/CHECKSUMS @@ -0,0 +1,30 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '2917421f5a41419f7bb2d2cf87f04b8d', + 'size' => 1066 + }, + 'perl5.005_03.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '2b70961796a2ed7ca21fbf7e0c615643', + 'size' => 119 + }, + 'Bundle-Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '76f9c0eed0de9f533ed4d3922bac2f11', + 'size' => 850 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.readme b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.readme new file mode 100644 index 0000000000..ba8894c152 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.readme @@ -0,0 +1,2 @@ +README + diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000000..c58d0e12eb --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,39 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed + +Created at Sat Apr 7 13:06:48 2007 +######################################################################### +__UU__ +M'XL("/8X34("`T9O;RU"87(M,"XP,2YT87(`[9KQ;]I&%,?Y^?Z*1YE$(A5C +M8YM(SE*-K69!*LD4Z%:IJZ(#'V!A^[SSN2F:]K_O#ML,6)ONAP+M\CY*XMCW +MS/EX]WWWGNT^YZT?J6B9AFFU:X?!5%RXKMY:%ZZUO:VH66:G8W=LQ^YV:Z;5 +M<1VS!F[M".29I`*@MJ0)>\SN<^W50*KM-T)_V_\_7?=N?O9'A_"_XSB?]G_' +M*?VO)L"%]K_M=MP:F.C_@S,`&@.%TO,P"R-&:LB384?_P][-H.^/Q@?0?_<1 +M_7?L_?BO_CJH_V-0"I_<^;V70Y\,Z9+I&&#\\HI4LX%(EDDCC4@43MIJOK35 +M?#'2F$S"I#WC?*+W(C+TQSUC%4?P.88\R",&,9.T%5!)X8P&`0M@L@+=N_X5 +MYQB#3J+_TH='UK_C=O;T[Z@4$/5_#!JPD#+UVNUX+<O6)`^CP,AX+J9LQL6< +M&0F3ZXG1RE(V-18RCDCC30&,%V$&ZH="*KCD<I6R>KT.,)#P$$813!<TF3,( +M$Y`+!K-<YF)ML#Z[01(:,V\3&,JI2-XSD84\*1OTQ*P.W<\$CSW8BT-AHEP8 +M14$H,G5.%DI&!/LC#P7+/$*",),BG.12GZ\OT(-BJ&3.$B:H9,']9.6!_T&^ +MEF&4>=XF"D'9+72-CDN>@/[+0'_T_+]K[>7_CNE<H/Z/HO]Z.\]$6Z_E*1,1 +M(:D($PG/+,.P?D^>75;[?`G%/BZ9_U_]Z\#Z5=S_L6VSB_=_3N)_O;">W/^. +M:5OH_Y/YOTBLCK7^:]?OK?^NB?7_<2!7"T8#"VYZJOHG(QJGJC9OZ5P<5&T/ +M67%`_4LJR][K\?7MW<9V2!/XOC#[@7U8;XTICU]L[&_'U[XRKW+I*$Q8IBN" +ME`>0+7@>J=)?E0CSA`L6>.2[7_V[T>#V!JZ@F7`)?.G!7&VK\W4)H,^M-R]5 +M%]-<JI2%3I=4E1GJHCU/S5W5T(!_]:<N*F:)S#[6:0/^4[?E1ZR[;JB2IBA^ +M=&FSW1L\L*9@$'&^#).Y^N[$SJC.FEIKS?.WYKM+@,;6Y;#W-&H&A/Q)]/$' +M5C7Q)%J!5!5)446I.D?N=CCC>:)&`:K/*8V(+IL^-9Z,37D2[`\K8'I,?Q%B +M88+WA/,_705\)?F?A<__3N/_S1W=+^M_]S'_.^[^^F]9^/SOI/5_,0U4O8]+ +MPM.)_UM/?[YT_'],_QW7WK__YUHVZO\XPV<?N_6M=/^;""6K9L39.JG41<+V +MH[RK%]"LDN[F\[5)F7;>]^]NAY7);EE9&OIO_/O^X)4_^N>SWC9W%J#FN^>Z +M@9Q?K@TP"AU<_\5#X(/D?X^__[.O?]NQ+-3_,2C?_RD\CZ__(`B"(`B"(`B" +?(`B"(`B"(`B"(`B"(`B"(`B"(,@WP=^)5B"Y`%`````` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed new file mode 100644 index 0000000000..cb93428215 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed @@ -0,0 +1,18 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed + +Created at Sat Apr 7 13:06:48 2007 +######################################################################### +__UU__ +M'XL(`'3DO44``^W/,0J`,`Q`T1RE)Y"T-O4XXN"DB%2]OR(*NNC4[;_E#\F0 +MS'T>K5*U5FLI1`\IQK--LE<OXM6LJ5/P,8CZ8$'%::F#GK9E[;)S,G13_[7W +=-[\?N0L`````````````````0$$[-9`]0P`H```` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/CHECKSUMS new file mode 100644 index 0000000000..f124759db0 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/CHECKSUMS @@ -0,0 +1,20 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => 'c7691a12e5faa70b3a0e83402d279bd6', + 'size' => 1589 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.readme b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.readme new file mode 100644 index 0000000000..ba8894c152 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.readme @@ -0,0 +1,2 @@ +README + diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000000..fd1640911e --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,51 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed + +Created at Sat Apr 7 13:06:48 2007 +######################################################################### +__UU__ +M'XL("`DY34("`T9O;RU"87(M,"XP,2YT87(`[5IK3]M(%,U7YE=<H%5``A.; +M/*0@5@0P-"IY*`E=JFX53>))8F%[4L\8B%#_^][Q(P^VI5\VZ78[1P0G]IWG +MO>?,^-I7G!^>T_"P8!3,H]QZ4$!42B5U-"LE<_F8(6<6+.O8.BX633QO6B6K +MDH-2;@.(A*0A0.Z>!NPUNQ]=SP:2'7\17"W[_^)=K7EM=]?A_V*Q^'W_6\74 +M_Q@`E3+Z_[ADE7)0T/Y?.^I`?:"0>AY&KL=(3N.WP0K_&[5F_<KN]C:L_Q:* +M_:K^'Y?+1<W_32`E/NG8M<N&3;(((`UZSY08&.T;@O%A3/WX\"2(9$(:4X\, +MW.!HQ/E`7?1(P^[5C)GOP8_0X$[D,?"9I(<.E13VJ.,P!P8S4&VJ3[BO)>CG +M\#]UXAKX7WYE_2\6K27^%Q3_*Y6*YO\FL`L3*:?5HR,_YN7A('(]QQ`\"H=L +MQ,,Q,P(FX\`X%%,V-";2]\CN70+H35P!^$=A&G+)Y6S*MK>W`>H2'EW/@^&$ +M!F,&;@!RPF`4R2B,#>+2NR2@/JO.E2$-1?+`0N'R(+V@`C,[U1^%W*]"JD=N +M@*[S/,<-!=H*5S(2LB^1&S)1)<1QA0S=0215.=6Q*B1#)&,6L)!*YO0'LRK8 +M3_)6NIZH5N?R`VES4#:L$OF-^)]*^SKV_Z77[O\JA1?[_V*A9&G^;P+G]G6] +M"<_(7S>0L&,:AOE7L`-?3T@DF*)DM8KA<4+2Z_P>U/43O4#_'_FOMG3_B?S/ +ML571^9^?X__YEGZ#^E\LO=#_DFGJ_,]F]G_;1Y$(8\]/6>B13.B3,$"A)Z86 +M^]]%_Y,[_+7H_VO\MY#S+_*_9:NL^;\1_KO!T(L<!COV7<_N-(W)#EF<4Y*P +M>N:N>WNNSI!&Z_+VQH;3^1YQ:ZM=NWA?NUX]1_`V31)7]-D#"_;<8!K)?;*E +M)$8A_DW4MXO6I5TE6QV[]Z%V@S4DIO`6+#@]A<+^26S5NNVU;WMS.RU,_S[_ +MI_ZF^6]9Q<H_^&\6-/\W@2D=WM/Q\IV>NN]3J9.AQ,4_3:B`_33EH61X.3MS +M.0OH#:<.2XL\T%#`E\<].*MW:_#6OFNW.KU^KW;=A;/T1^M]]A7>?+`[W7JK +M"4AL$I<X586S9I9J5P:[4)?,%R`YL-@"A0._#ZGG,6Q5I9$$#H2I)++#1C3R +MI`%-+ED5'`X!EVDQK"BV7;*#1U=.."H-55F?&8PY=R!D5/#`@%L<UZ+O*M_$ +MJ&-@+9=)K<+UI]XLZQ/V!F8\"F$:#3QW"*,H&*KLDSCR&;;AB*,A5RFK0`I# +MC2E.GF$A_BBP-T./AE29;ZG9O.OVF)"0K^+U_(F:@)&J.QM.P)@#$LL?@,\? +MW&"L?@1CK`==,Y38IWB"LMGFX9(/L+(X-R?H@TK#^SR<&63%7ZB^D%<-P^D? +M\$GYA6R1??B<.&LQ(<KN[!G>+)5]CLM]A:_+MHEO51TG9.[X4\@KS<'!D0'G +M$B..3N=1.(^/V/GMD'DJ%AQ()Q*]!!,6,B/>G?;[=O.RWT?#<[1[5/E((:,! +MSM4P\ED@XUF%$4Y"[)TD"VC`1YS.`9,JVICC8DC);4).)^AA$YJUADU(ZH1# +M:.,RB%Z6+!!950./3A;_Y@6['YNM=K?>);A<+?RH%J_O%+BTNQ>=>KN'8R6D +M^^UN)Y4<P!#C4B:/2B;6DS!4FM7C_%Z`Y]XSE6(E-,()"H&/XH3KHLN/%&G" +MQIX[QIJ!!3P:3Q2=/*:B0-FJ*2-1H*:"88R3\Y7^&FF'K90/A#1YL,(W,A]2 +M[;;WKM4AI(8$,C#*>7@`U(@,U;,S:HRI1Y]FQ@C7&O6ACW2VF#[;AMI-MX6W +M(3CE>^:^:G>(6P2]4&]B_5]ZZ+?1_7_Y^&7^MV3JY[^YS0R??>L1".KNGR$J +M0181>_'V.Z]T,;]XEHO+0SZ3[/Q!8I(*=_^JTVKD$Y-D6YD_@%T8N0'*=Z;N +M<0G[SNY?U6_L[J+23_F53%3^\T'6HEI"-&G7Q?_D)8"U[/]??__K)?^/51I8 +M\W\#2-__2CRO7__2T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0 +.T-#X9?`W%LHWQP!0```` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/CHECKSUMS new file mode 100644 index 0000000000..042008cc56 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/CHECKSUMS @@ -0,0 +1,20 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '1f52c2e83140814f734c8674e8fae53f', + 'size' => 867 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.readme b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.readme new file mode 100644 index 0000000000..ba8894c152 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.readme @@ -0,0 +1,2 @@ +README + diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000000..11ada7ef22 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,35 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed + +Created at Sat Apr 7 13:06:48 2007 +######################################################################### +__UU__ +M'XL("-<X34(``T9O;RU"87(M,"XP,2YT87(`[9E;;]HP%,=Y]J<X+9722@-R +M!0G6:G2#M=)*I]+MI:M0((9&)#;*I5TU[;O/)J1JH!WK%-)U/;\7XTOXVSD^ +M]G'<Y;QR:`<5M:IJM=)F4`4-RY*IUK"T^VE*25-UW=`-T]`;)573+<,J@;6A +M_F2(P\@.`$I3F]'?M5M7GPXD35\(W?OV?W_4[GWL]//6D.^C;IJ/VU\WE^QO +M6*(("GF)K]S^QV#[8,/"\C!V/4J>NT](<63\_Z3=.^YV^N<Y:ZSS?TVM+_M_ +MO6Z@_Q?!PO')6:?]X:1##F/7<ZJ?/Y%T*I"(AE%UYA'/'=;$9*F)R5*=^63H +MLMJ8\Z',>;ABO%@R_K^P==X::_?_NK;D_Z9JUM'_BZ"\58O#H";=>48#CY!9 +MX+((MK5J5?O&MEMIGD\AR3]WAY%<R?B_7.,WH/'T\Y]AJ`:>_XI@Q?YRC\]9 +MX^GV-U6]CO8O@@?MG\1XN6FLV?^EZ9?L;ZD8_Q<#V;^BMJ-!KRVB?]*W_9E' +MH0)B%H`([R%,"L1/DK9L?SD_.CV[:WMB,WB;-'M'O\_3ZHC[!W?M3\^/.J+Y +M-0U"ES/P7$9#<!G,N`/A%8\]!X84W`GC`76:9.=KYZQ_?-J#?5`8CX!/FS`1 +M:?K\.."^?'9+:0F)41R)D,4>3>T)E9UN-L7<%15E6-$3G?(IB\*'1,OP1[*+ +MOYA+ER&Z<L4?AR*E&36XH4I`P>-\ZK*)>'=!9E2[BO0U9>]"O6P!E.]UAU[; +MGN(0\H/(\AN:5G'FW4)D3^E<:NP&8905'/.8B5&`T!S9GDCAT?&$=,29LSPL +MA\HQ_21$PP#O=9%9_^4I8`,:?Q7_X??_0EBQ_]U'G?PTUI[_36MY_]<T#??_ +M(GCL_)],`W'>QRWAOR;C_^G7WYPUUOF_;C16SG\&QO^%$(<BA.=.[%$1.DOS +MMX`0_Q9VAC(CHD=&;[(-1'BY*T-,?UXX8+9/8?\`E#3Z5M[(VG`4N+-H(.\3 +M0UE]`4IF=U'@4K;;:Y%$J7(P"J@=T<$\-T@>QY5GXV3\/[D$REUC[?ZO&\OQ +MGZFIZ/]%L+C_3RR/U_\(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`( +,\D_S"QCQWFL`4``` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/CHECKSUMS new file mode 100644 index 0000000000..5d2a6d6ee3 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/CHECKSUMS @@ -0,0 +1,20 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '986e4316ac095d8a4d47d0d0dd2c408a', + 'size' => 1541 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.readme b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.readme new file mode 100644 index 0000000000..ba8894c152 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.readme @@ -0,0 +1,2 @@ +README + diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000000..148930eb47 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,50 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed + +Created at Sat Apr 7 13:06:48 2007 +######################################################################### +__UU__ +M'XL("-\X34(``T9O;RU"87(M,"XP,2YT87(`[5K_3QI)%/=7YZ]XU39H(BN[ +M@%PP-*)N+:D"$6QL[AHRP``;EQVZ.RN2IO][WV,79+4]KG>(UW8^B<+NO)GW +MYGV;F3>\D3)]S/UTQLB8^QM/@PRBD,_3IUG(FXN?,VR8&<O*6ME<-EO8R)A6 +M/GNP`?DGDB>!,%#<!]BXX9[X.[IE[;.)S#Y_$KQ9M/_)VW+US&ZLF@?IXR"7 +M^[[]K=P#^V?S5GX#UJ+$W]S^%>!#X!!;'GJ.*]ASRZ2Q/B3B_Z)<K;RQ&\T5 +M\U@6_R8F^P?Q?W!0T/&_#K0=;[\G99O[QLAEQZ'C=HWZ.8OS`7.=]CZZR/XQ +MM0\3CW<!F_D+N[3+IQ<V4R)0-,R%W2P;DZ&K,\G_'HGX)_,^`8\?W_]ELYF< +MWO^M`X_L3^&]8AX_;O]<QBIH^Z\#W[1_E-Y7QF/9^F\5'J[_>=/,Z?5_'=AV +MO(X;=@5LV==-^[)J#+;8_;N1\-WDF^O&U3&]81>UTZMS&TJ`#E,LHL=L;M;+ +M)^_*9\EWC#F>8D[0$K?"VW&\4:AVV2:^`\+TF=&WD]JI762;EW;S??D<1XA( +MX1584"I!9O=P2E6[:M:OFG,ZO;_XS_AN_(^&*^.Q)/XM*U=X&/\93`DZ_M>` +M$>_<\+Z81^PA"P,!@?*=CCIDS!>?0L<78-^-I*\$-L_>G$X\?BYY5\1=;KD? +MP*?Q#AQ5&F5X95_7:Y?-5K-\UH"C^*'V;O857KZW+QN56A4PL-FT1XDZS]@L +MC$X$VU!18AB`DB"F%)@X\'N'NZY`KAX?B@`G(J`]@:[H\=!5!E2E$D7H2O"D +MBKOA0%/:!3H8.VH@,=-PN!7^!/I2=L$7/)">`5<XKWO9'2]0@G<-'.4T&C5P +MAB-W,I,)I8&)#'T8A6W7Z4`O]#K*D5ZP/Q3(HQOL=_!!<4\%!LVI.7`"ZB3' +M`4K3<;G/B7R3M'G=:.)9"E)%;$\=D@)Z-/9L.IX075#8?P^&\M;Q^O3@]7$< +M-$U'H4Q3!<VT+?T%&^!@8P=%#?BM@*$82G]BL(2],/M"BAA#Z37\279AFVP7 +M/D;&NE<(T1U]AI<+?3]/^WV!+XNTD6UIC$,V-WP)4I1S<'*L+:5"C^.CN1?. +M_6-J_+HO7/*%+L2*1"O!0/@"U6@>LE;+KIZV6DAXC'1C0*T&*FRCKCKA4'AJ +MJE7HH1*FUAG*;N@*`SZ@.MM"D;>)KH,NI5XP5AJ@A4VHEO$TRV(CI*&.RR!: +M60DOF`W5=OG@_M^\8^-#M59O5!H,EZM[.]+B]9T.IW;CY+)2;^)<&6M\6^QH +MD#WHH%\JU`)Z[\"Z"PR,"G"EO`G`=6X$NH!@/$0%^2![]+0@\IACF(B^Z_1Q +M9!">#/L#"B=7D!<0+:F,A1ZI0J"/L^.$O$8LL!7'`V-5Z27BC<VG5+YJOJU= +M,E;&`#+0RZ6_!]P(#9+LB!M][O*[B='#-8;^^)A/[M5GVU`^;]08HYW'CKE+ +M?#NX17CN-/G+(EG_B^LV*^:Q;/^?S68?G?\R>OU?"]+I-&Q_*%^<%TTCPVAU +M+$+L$PP71$H>12#GB%-+$5-9&GX@M'F;4GM'%?]!%L55$QM1@M"[\>388YBM +MA$\YK]6>%.%BFKEQ@:`J)<32H7#60>8/<V^^DM-LJ%CYW*K]*9"(_[A^NVH> +MR^(_4WA<_\GI^O]:<&R?5:KP&48^G<FW3,,P__*VX$NTJ;\_%<3M\@:H_5`' +MUR^"1/S39=`3\/A7]7_]^X^UX)']YY>!J^.Q-/_G\H_KOY;._^O`]HO],/"G +MEJ<C%YLE^L@-,-'3"?NYA=1X,B3B/[K&7SF/I?%O/3S_97.FJ>-_'8A__Q59 +M7O_\Z[=#(OYG/_]9,8]E\6_EOG'_K^L_:P&=\A)U%5SQAQ-XV9[66$K@B?&# +MN@L#V*'+V*B.WJ*2$=T3I&9GQ=0>M08=WQFI%B64(+I&2"5VERGX2'1T2Q#Q +M2K^.RMNMZ5,KZJ^W'AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH: ++R_`55?+KB0!0```` diff --git a/lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed new file mode 100644 index 0000000000..696ae1572b --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed @@ -0,0 +1,25 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed + +Created at Sat Apr 7 13:06:48 2007 +######################################################################### +__UU__ +M'XL("-%#OT4``S`R<&%C:V%G97,N9&5T86EL<RYT>'0`E=-1:]LP$`#@=_^* +M>]C#!K&D.IB"GAJGR=B6=&5M:-^&:ET3,5LRTKE>]NLG-2TM(6FWX\!@WWVZ +M`WEN&I3P'*+H5/U+K3$PC:1,$QC]IFSU8_%2`QNB3G(^#`/KT#>L=BV?7DXN +M>.MTWV#@1Y1S#+4W'1EGHW:Y*P&K6@QP[WJKP5C0QF--SF_APZ.I>MHX'[C1 +M/)NZIF]M>!JE>P6,X`%]B/`HOJ9-]L426HTZGSLO8=*3:Q6AAGND>@/>]60L +MAM'N\`@A:%?W+5I2:3R6W7A#D<BK;3JM;;0)-*C4_/$!"C86Q2>XV\+$:H\J +ML&\.K5F?*6M:%7?.%I'/IW$G2NTGXK0LLX4*E*\ZG0:1<(-Z!&,!7Y6%0H@" +M1"F+F*?P>7F=97/GI*R4EW*VDO+V"O9",'&2GC,^6\6\O>*Q(X\->?K"2'FV +M_O-*659O*4N^K&+^DW+Q?=_94U+!.T[:Z;CSM-.[SOXV_^M4\<K%RR^/>8>< +B74]^B)L.^MA$CU$<X-+_4S(ARI]B_.QD?P$Z!("8DP,````` diff --git a/lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed new file mode 100644 index 0000000000..e4fb69c0a1 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed @@ -0,0 +1,28 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed + +Created at Sat Apr 7 13:06:48 2007 +######################################################################### +__UU__ +M'XL("#'FO$4``S`S;6]D;&ES="YD871A`%U3_6O;,!#].?HKCBXC"20A=<@& +M"@OIYV!;/Z`-&V1E*/:U%I4M(\D-)N1_WTFVFVS&H.=W>N^>SO:U5,BAN2;3 +M3"=*6C=.A!/L$FUL9.&DSCD\IF@1A$%P*8*O$Q`N,$6Y(56*"<@\E,FF5,@Z +MWFL(F])YMH),5+#Q5=(8C#'WO*@E2CBT#@IM'2:L4SN$+'#WA@:<S!"VV%.* +M;%X1;!FBB&!MZT2L$Y,;=2@M97$:"B-##U*F6E%08>AQJT$_>_;?-A>E,11) +M5522%NC.=2V.A<4QN]%)K,O<A7%%T]F,_332.<Q'YQ5QF4K(9BM<G$+_#:+Q +M=!(-8%/!69X8%';\76,N7Y8BEYD8)\@NZ<3OH[\V<@C1#+[1`:+))(+))QY] +MYI,I?+UY9,QO*43\*EX0+N[/;CF_>4\^#]4/L+)4Y<V9R5QP?EEF!9K1(L=M +M?_V_;K3P,WL:C!9^&V@#5F92"1/\;+FIW_*.U0FS"KH&;:D<?('=?GY$4\M, +MF(KX$QJH3$[:XC.9]I==[S/8T;0K^)@*F\Y99^G7W;(;:V7W)%QV_Q#;-!@M +M=MU0;YWW?LOO1EM;[YNUD<SK&>T9"Y:T?4U$+\3I#3VT3K@C:`]0':`\P**& +MR>$GJ`GZMDSK&:>B<.&1/5&"<-"F]3KDZ5UKS?FY,)Q?K3B_O?OU$)1>VX*D +K!44+[EK0KO[5W?]8/<"C_T?NZP^A+5ZMCFU/3WL$GH8^T%]3O>X%W0,````` diff --git a/lib/CPANPLUS/t/dummy-localmirror/01mailrc.txt.gz.packed b/lib/CPANPLUS/t/dummy-localmirror/01mailrc.txt.gz.packed new file mode 100644 index 0000000000..34ac29d6ee --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/01mailrc.txt.gz.packed @@ -0,0 +1,19 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-localmirror/01mailrc.txt.gz.packed lib/CPANPLUS/t/dummy-localmirror/01mailrc.txt.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-localmirror/01mailrc.txt.gz lib/CPANPLUS/t/dummy-localmirror/01mailrc.txt.gz.packed + +Created at Sat Apr 7 13:06:49 2007 +######################################################################### +__UU__ +M'XL("%_EO$4``S`Q;6%I;')C+G1X=`!+S,E,+%9P#8T(5@`#)=>*DM"2S)QB +M*RO?Q.Q4$"Y2`$HZYZ>D*M@D%R3F%>24%CND5B3F%N2DZB7GY]HI<25"#?'S +MAQB#U1"_?"+-\76".\8W/Z4T)]7*RJDT,R>%:.UP9Z!J]_,G:`(`W)]=R`X! +"```` diff --git a/lib/CPANPLUS/t/dummy-localmirror/02packages.details.txt.gz.packed b/lib/CPANPLUS/t/dummy-localmirror/02packages.details.txt.gz.packed new file mode 100644 index 0000000000..472cbde8b8 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/02packages.details.txt.gz.packed @@ -0,0 +1,25 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-localmirror/02packages.details.txt.gz.packed lib/CPANPLUS/t/dummy-localmirror/02packages.details.txt.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-localmirror/02packages.details.txt.gz lib/CPANPLUS/t/dummy-localmirror/02packages.details.txt.gz.packed + +Created at Sat Apr 7 13:06:49 2007 +######################################################################### +__UU__ +M'XL("-%#OT4``S`R<&%C:V%G97,N9&5T86EL<RYT>'0`E=-1:]LP$`#@=_^* +M>]C#!K&D.IB"GAJGR=B6=&5M:-^&:ET3,5LRTKE>]NLG-2TM(6FWX\!@WWVZ +M`WEN&I3P'*+H5/U+K3$PC:1,$QC]IFSU8_%2`QNB3G(^#`/KT#>L=BV?7DXN +M>.MTWV#@1Y1S#+4W'1EGHW:Y*P&K6@QP[WJKP5C0QF--SF_APZ.I>MHX'[C1 +M/)NZIF]M>!JE>P6,X`%]B/`HOJ9-]L426HTZGSLO8=*3:Q6AAGND>@/>]60L +MAM'N\`@A:%?W+5I2:3R6W7A#D<BK;3JM;;0)-*C4_/$!"C86Q2>XV\+$:H\J +ML&\.K5F?*6M:%7?.%I'/IW$G2NTGXK0LLX4*E*\ZG0:1<(-Z!&,!7Y6%0H@" +M1"F+F*?P>7F=97/GI*R4EW*VDO+V"O9",'&2GC,^6\6\O>*Q(X\->?K"2'FV +M_O-*659O*4N^K&+^DW+Q?=_94U+!.T[:Z;CSM-.[SOXV_^M4\<K%RR^/>8>< +B74]^B)L.^MA$CU$<X-+_4S(ARI]B_.QD?P$Z!("8DP,````` diff --git a/lib/CPANPLUS/t/dummy-localmirror/03modlist.data.gz.packed b/lib/CPANPLUS/t/dummy-localmirror/03modlist.data.gz.packed new file mode 100644 index 0000000000..d4f9e78237 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/03modlist.data.gz.packed @@ -0,0 +1,28 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-localmirror/03modlist.data.gz.packed lib/CPANPLUS/t/dummy-localmirror/03modlist.data.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-localmirror/03modlist.data.gz lib/CPANPLUS/t/dummy-localmirror/03modlist.data.gz.packed + +Created at Sat Apr 7 13:06:49 2007 +######################################################################### +__UU__ +M'XL("#'FO$4``S`S;6]D;&ES="YD871A`%U3_6O;,!#].?HKCBXC"20A=<@& +M"@OIYV!;/Z`-&V1E*/:U%I4M(\D-)N1_WTFVFVS&H.=W>N^>SO:U5,BAN2;3 +M3"=*6C=.A!/L$FUL9.&DSCD\IF@1A$%P*8*O$Q`N,$6Y(56*"<@\E,FF5,@Z +MWFL(F])YMH),5+#Q5=(8C#'WO*@E2CBT#@IM'2:L4SN$+'#WA@:<S!"VV%.* +M;%X1;!FBB&!MZT2L$Y,;=2@M97$:"B-##U*F6E%08>AQJT$_>_;?-A>E,11) +M5522%NC.=2V.A<4QN]%)K,O<A7%%T]F,_332.<Q'YQ5QF4K(9BM<G$+_#:+Q +M=!(-8%/!69X8%';\76,N7Y8BEYD8)\@NZ<3OH[\V<@C1#+[1`:+))(+))QY] +MYI,I?+UY9,QO*43\*EX0+N[/;CF_>4\^#]4/L+)4Y<V9R5QP?EEF!9K1(L=M +M?_V_;K3P,WL:C!9^&V@#5F92"1/\;+FIW_*.U0FS"KH&;:D<?('=?GY$4\M, +MF(KX$QJH3$[:XC.9]I==[S/8T;0K^)@*F\Y99^G7W;(;:V7W)%QV_Q#;-!@M +M=MU0;YWW?LOO1EM;[YNUD<SK&>T9"Y:T?4U$+\3I#3VT3K@C:`]0':`\P**& +MR>$GJ`GZMDSK&:>B<.&1/5&"<-"F]3KDZ5UKS?FY,)Q?K3B_O?OU$)1>VX*D +K!44+[EK0KO[5W?]8/<"C_T?NZP^A+5ZMCFU/3WL$GH8^T%]3O>X%W0,````` diff --git a/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000000..b76bf9d75b --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,34 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed + +Created at Sat Apr 7 13:06:49 2007 +######################################################################### +__UU__ +M'XL("!1%OT4"`T)U;F1L92U&;V\M0F%R+3`N,#$N=&%R`.V7:V_:,!2&^8I_ +MQ6F91"L52"`)6KI6`Q8TI`$5EZW2-"%##%C-K8FSEDW[[W,2:&E$6VGKH$Q^ +M(`KR<4YB7K_'3CUT3(L4FJY;J&._(!4EN91Y821.5563LY:<.:MS_%N65+6J +M*67^R4BR(E<J&5`S6R`,&/8!,E?8(4_UNYD38CTSR+5!9?:$^@;]+3HN[5C_ +MJB0+_7>I?])>VI'^FBR7A?ZO0'_>7MJ%_EI%%?J_$OUY>]&S_U)_35$>U5^5 +MM'O]I2K7OQK7?TGH_\_Q\.0*SP@D>NLZ%US7N>*G"+WY;/3ZK6X'SN`PFA>' +MO$WFQVAD=#Z,1@B=S0DV9>C4V@9"Z01P%V]T.P.C,^@CM(KINC'4]<L^<*+, +MZ4BG&\72D7;]L6NBR/HUC1L3TB21Y2/5AH./W1Y"QBT;,FH%/`6^(M'A0\<% +MGJGAF@3>33SL>%88O">WV/8L4IRX]CG/,@D9']_]/Y'96S;Y/_H?II2/]N+3 +MBZW_3_I?45?^E\OE<KS^2XKP_W:&3V"#"TY1%`B83R>,6_Z+3QE930LX0I&A +M(MNO&^SL'/+I(I`_B;LN"\FHV>NV5UTW+C+Y$\C!E#IF`*OJ$R<P:<!2]_K) +MZTK[HF?T^W&ZV0_J0>'ME&?H#YO-UN6R-0^_DF=(+/_P<?_(_GQ,V5J]/^C5 +M&H.U9-=?TX/_=H*.3Z,HVC?_USJMIM$?O.3[WU/^+\O5U/Y/+6O"_UMAHPW1 +MV@J`5K,AF\T.YC0`*_*B.X4H'J"V,:@5%[8%S]%VS9#7#ILP7#`QPW"$39.8 +M,%[`G?F.]W@A_9_6_Z6FV_*_4DV__ZF*I`K_;X,<S!GS]%+)COU9&(?4,HN! +M&_H3,G7]&2DZA,4SHA!X9%*<,]M"N<L$B`L"_V+P?)>Y;.&1@X,#@!:#&VI9 +M,)ECA[]<4`?8G,`T9*$?=XBOSB$'VT2_JQ`/IR+Z3OR`NHZ^MGU?-HVFOFOK +ML+ET48<+:EDF]0-^:<#W+<@GUR'U2:`C%&TD?#H.690F>EP=DH&C&7&(CQDQ +H1^.%OFE+!,N[@U:L2*)0"00"@4`@$`@$`H%`(-@;?@-?EF['`"@````` diff --git a/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/CHECKSUMS new file mode 100644 index 0000000000..e716d3635c --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/CHECKSUMS @@ -0,0 +1,30 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '2917421f5a41419f7bb2d2cf87f04b8d', + 'size' => 1066 + }, + 'perl5.005_03.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '2b70961796a2ed7ca21fbf7e0c615643', + 'size' => 119 + }, + 'Bundle-Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '76f9c0eed0de9f533ed4d3922bac2f11', + 'size' => 850 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000000..52c855198b --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,39 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed + +Created at Sat Apr 7 13:06:49 2007 +######################################################################### +__UU__ +M'XL("/8X34("`T9O;RU"87(M,"XP,2YT87(`[9KQ;]I&%,?Y^?Z*1YE$(A5C +M8YM(SE*-K69!*LD4Z%:IJZ(#'V!A^[SSN2F:]K_O#ML,6)ONAP+M\CY*XMCW +MS/EX]WWWGNT^YZT?J6B9AFFU:X?!5%RXKMY:%ZZUO:VH66:G8W=LQ^YV:Z;5 +M<1VS!F[M".29I`*@MJ0)>\SN<^W50*KM-T)_V_\_7?=N?O9'A_"_XSB?]G_' +M*?VO)L"%]K_M=MP:F.C_@S,`&@.%TO,P"R-&:LB384?_P][-H.^/Q@?0?_<1 +M_7?L_?BO_CJH_V-0"I_<^;V70Y\,Z9+I&&#\\HI4LX%(EDDCC4@43MIJOK35 +M?#'2F$S"I#WC?*+W(C+TQSUC%4?P.88\R",&,9.T%5!)X8P&`0M@L@+=N_X5 +MYQB#3J+_TH='UK_C=O;T[Z@4$/5_#!JPD#+UVNUX+<O6)`^CP,AX+J9LQL6< +M&0F3ZXG1RE(V-18RCDCC30&,%V$&ZH="*KCD<I6R>KT.,)#P$$813!<TF3,( +M$Y`+!K-<YF)ML#Z[01(:,V\3&,JI2-XSD84\*1OTQ*P.W<\$CSW8BT-AHEP8 +M14$H,G5.%DI&!/LC#P7+/$*",),BG.12GZ\OT(-BJ&3.$B:H9,']9.6!_T&^ +MEF&4>=XF"D'9+72-CDN>@/[+0'_T_+]K[>7_CNE<H/Z/HO]Z.\]$6Z_E*1,1 +M(:D($PG/+,.P?D^>75;[?`G%/BZ9_U_]Z\#Z5=S_L6VSB_=_3N)_O;">W/^. +M:5OH_Y/YOTBLCK7^:]?OK?^NB?7_<2!7"T8#"VYZJOHG(QJGJC9OZ5P<5&T/ +M67%`_4LJR][K\?7MW<9V2!/XOC#[@7U8;XTICU]L[&_'U[XRKW+I*$Q8IBN" +ME`>0+7@>J=)?E0CSA`L6>.2[7_V[T>#V!JZ@F7`)?.G!7&VK\W4)H,^M-R]5 +M%]-<JI2%3I=4E1GJHCU/S5W5T(!_]:<N*F:)S#[6:0/^4[?E1ZR[;JB2IBA^ +M=&FSW1L\L*9@$'&^#).Y^N[$SJC.FEIKS?.WYKM+@,;6Y;#W-&H&A/Q)]/$' +M5C7Q)%J!5!5)446I.D?N=CCC>:)&`:K/*8V(+IL^-9Z,37D2[`\K8'I,?Q%B +M88+WA/,_705\)?F?A<__3N/_S1W=+^M_]S'_.^[^^F]9^/SOI/5_,0U4O8]+ +MPM.)_UM/?[YT_'],_QW7WK__YUHVZO\XPV<?N_6M=/^;""6K9L39.JG41<+V +MH[RK%]"LDN[F\[5)F7;>]^]NAY7);EE9&OIO_/O^X)4_^N>SWC9W%J#FN^>Z +M@9Q?K@TP"AU<_\5#X(/D?X^__[.O?]NQ+-3_,2C?_RD\CZ__(`B"(`B"(`B" +?(`B"(`B"(`B"(`B"(`B"(`B"(,@WP=^)5B"Y`%`````` diff --git a/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed new file mode 100644 index 0000000000..34c30ca383 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed @@ -0,0 +1,18 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed + +Created at Sat Apr 7 13:06:49 2007 +######################################################################### +__UU__ +M'XL(`'3DO44``^W/,0J`,`Q`T1RE)Y"T-O4XXN"DB%2]OR(*NNC4[;_E#\F0 +MS'T>K5*U5FLI1`\IQK--LE<OXM6LJ5/P,8CZ8$'%::F#GK9E[;)S,G13_[7W +=-[\?N0L`````````````````0$$[-9`]0P`H```` diff --git a/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/CHECKSUMS new file mode 100644 index 0000000000..f124759db0 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/CHECKSUMS @@ -0,0 +1,20 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => 'c7691a12e5faa70b3a0e83402d279bd6', + 'size' => 1589 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000000..9516f202e1 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,51 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed + +Created at Sat Apr 7 13:06:49 2007 +######################################################################### +__UU__ +M'XL("`DY34("`T9O;RU"87(M,"XP,2YT87(`[5IK3]M(%,U7YE=<H%5``A.; +M/*0@5@0P-"IY*`E=JFX53>))8F%[4L\8B%#_^][Q(P^VI5\VZ78[1P0G]IWG +MO>?,^-I7G!^>T_"P8!3,H]QZ4$!42B5U-"LE<_F8(6<6+.O8.BX633QO6B6K +MDH-2;@.(A*0A0.Z>!NPUNQ]=SP:2'7\17"W[_^)=K7EM=]?A_V*Q^'W_6\74 +M_Q@`E3+Z_[ADE7)0T/Y?.^I`?:"0>AY&KL=(3N.WP0K_&[5F_<KN]C:L_Q:* +M_:K^'Y?+1<W_32`E/NG8M<N&3;(((`UZSY08&.T;@O%A3/WX\"2(9$(:4X\, +MW.!HQ/E`7?1(P^[5C)GOP8_0X$[D,?"9I(<.E13VJ.,P!P8S4&VJ3[BO)>CG +M\#]UXAKX7WYE_2\6K27^%Q3_*Y6*YO\FL`L3*:?5HR,_YN7A('(]QQ`\"H=L +MQ,,Q,P(FX\`X%%,V-";2]\CN70+H35P!^$=A&G+)Y6S*MK>W`>H2'EW/@^&$ +M!F,&;@!RPF`4R2B,#>+2NR2@/JO.E2$-1?+`0N'R(+V@`C,[U1^%W*]"JD=N +M@*[S/,<-!=H*5S(2LB^1&S)1)<1QA0S=0215.=6Q*B1#)&,6L)!*YO0'LRK8 +M3_)6NIZH5N?R`VES4#:L$OF-^)]*^SKV_Z77[O\JA1?[_V*A9&G^;P+G]G6] +M"<_(7S>0L&,:AOE7L`-?3T@DF*)DM8KA<4+2Z_P>U/43O4#_'_FOMG3_B?S/ +ML571^9^?X__YEGZ#^E\LO=#_DFGJ_,]F]G_;1Y$(8\]/6>B13.B3,$"A)Z86 +M^]]%_Y,[_+7H_VO\MY#S+_*_9:NL^;\1_KO!T(L<!COV7<_N-(W)#EF<4Y*P +M>N:N>WNNSI!&Z_+VQH;3^1YQ:ZM=NWA?NUX]1_`V31)7]-D#"_;<8!K)?;*E +M)$8A_DW4MXO6I5TE6QV[]Z%V@S4DIO`6+#@]A<+^26S5NNVU;WMS.RU,_S[_ +MI_ZF^6]9Q<H_^&\6-/\W@2D=WM/Q\IV>NN]3J9.AQ,4_3:B`_33EH61X.3MS +M.0OH#:<.2XL\T%#`E\<].*MW:_#6OFNW.KU^KW;=A;/T1^M]]A7>?+`[W7JK +M"4AL$I<X586S9I9J5P:[4)?,%R`YL-@"A0._#ZGG,6Q5I9$$#H2I)++#1C3R +MI`%-+ED5'`X!EVDQK"BV7;*#1U=.."H-55F?&8PY=R!D5/#`@%L<UZ+O*M_$ +MJ&-@+9=)K<+UI]XLZQ/V!F8\"F$:#3QW"*,H&*KLDSCR&;;AB*,A5RFK0`I# +MC2E.GF$A_BBP-T./AE29;ZG9O.OVF)"0K^+U_(F:@)&J.QM.P)@#$LL?@,\? +MW&"L?@1CK`==,Y38IWB"LMGFX9(/L+(X-R?H@TK#^SR<&63%7ZB^D%<-P^D? +M\$GYA6R1??B<.&LQ(<KN[!G>+)5]CLM]A:_+MHEO51TG9.[X4\@KS<'!D0'G +M$B..3N=1.(^/V/GMD'DJ%AQ()Q*]!!,6,B/>G?;[=O.RWT?#<[1[5/E((:,! +MSM4P\ED@XUF%$4Y"[)TD"VC`1YS.`9,JVICC8DC);4).)^AA$YJUADU(ZH1# +M:.,RB%Z6+!!950./3A;_Y@6['YNM=K?>);A<+?RH%J_O%+BTNQ>=>KN'8R6D +M^^UN)Y4<P!#C4B:/2B;6DS!4FM7C_%Z`Y]XSE6(E-,()"H&/XH3KHLN/%&G" +MQIX[QIJ!!3P:3Q2=/*:B0-FJ*2-1H*:"88R3\Y7^&FF'K90/A#1YL,(W,A]2 +M[;;WKM4AI(8$,C#*>7@`U(@,U;,S:HRI1Y]FQ@C7&O6ACW2VF#[;AMI-MX6W +M(3CE>^:^:G>(6P2]4&]B_5]ZZ+?1_7_Y^&7^MV3JY[^YS0R??>L1".KNGR$J +M0181>_'V.Z]T,;]XEHO+0SZ3[/Q!8I(*=_^JTVKD$Y-D6YD_@%T8N0'*=Z;N +M<0G[SNY?U6_L[J+23_F53%3^\T'6HEI"-&G7Q?_D)8"U[/]??__K)?^/51I8 +M\W\#2-__2CRO7__2T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0 +.T-#X9?`W%LHWQP!0```` diff --git a/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/CHECKSUMS new file mode 100644 index 0000000000..042008cc56 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/CHECKSUMS @@ -0,0 +1,20 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '1f52c2e83140814f734c8674e8fae53f', + 'size' => 867 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000000..fe43f9239b --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,35 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed + +Created at Sat Apr 7 13:06:49 2007 +######################################################################### +__UU__ +M'XL("-<X34(``T9O;RU"87(M,"XP,2YT87(`[9E;;]HP%,=Y]J<X+9722@-R +M!0G6:G2#M=)*I]+MI:M0((9&)#;*I5TU[;O/)J1JH!WK%-)U/;\7XTOXVSD^ +M]G'<Y;QR:`<5M:IJM=)F4`4-RY*IUK"T^VE*25-UW=`-T]`;)573+<,J@;6A +M_F2(P\@.`$I3F]'?M5M7GPXD35\(W?OV?W_4[GWL]//6D.^C;IJ/VU\WE^QO +M6*(("GF)K]S^QV#[8,/"\C!V/4J>NT](<63\_Z3=.^YV^N<Y:ZSS?TVM+_M_ +MO6Z@_Q?!PO')6:?]X:1##F/7<ZJ?/Y%T*I"(AE%UYA'/'=;$9*F)R5*=^63H +MLMJ8\Z',>;ABO%@R_K^P==X::_?_NK;D_Z9JUM'_BZ"\58O#H";=>48#CY!9 +MX+((MK5J5?O&MEMIGD\AR3]WAY%<R?B_7.,WH/'T\Y]AJ`:>_XI@Q?YRC\]9 +MX^GV-U6]CO8O@@?MG\1XN6FLV?^EZ9?L;ZD8_Q<#V;^BMJ-!KRVB?]*W_9E' +MH0)B%H`([R%,"L1/DK9L?SD_.CV[:WMB,WB;-'M'O\_3ZHC[!W?M3\^/.J+Y +M-0U"ES/P7$9#<!G,N`/A%8\]!X84W`GC`76:9.=KYZQ_?-J#?5`8CX!/FS`1 +M:?K\.."^?'9+:0F)41R)D,4>3>T)E9UN-L7<%15E6-$3G?(IB\*'1,OP1[*+ +MOYA+ER&Z<L4?AR*E&36XH4I`P>-\ZK*)>'=!9E2[BO0U9>]"O6P!E.]UAU[; +MGN(0\H/(\AN:5G'FW4)D3^E<:NP&8905'/.8B5&`T!S9GDCAT?&$=,29LSPL +MA\HQ_21$PP#O=9%9_^4I8`,:?Q7_X??_0EBQ_]U'G?PTUI[_36MY_]<T#??_ +M(GCL_)],`W'>QRWAOR;C_^G7WYPUUOF_;C16SG\&QO^%$(<BA.=.[%$1.DOS +MMX`0_Q9VAC(CHD=&;[(-1'BY*T-,?UXX8+9/8?\`E#3Z5M[(VG`4N+-H(.\3 +M0UE]`4IF=U'@4K;;:Y%$J7(P"J@=T<$\-T@>QY5GXV3\/[D$REUC[?ZO&\OQ +MGZFIZ/]%L+C_3RR/U_\(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`( +,\D_S"QCQWFL`4``` diff --git a/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/CHECKSUMS new file mode 100644 index 0000000000..5d2a6d6ee3 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/CHECKSUMS @@ -0,0 +1,20 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '986e4316ac095d8a4d47d0d0dd2c408a', + 'size' => 1541 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000000..ed67a73a41 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,50 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed + +Created at Sat Apr 7 13:06:49 2007 +######################################################################### +__UU__ +M'XL("-\X34(``T9O;RU"87(M,"XP,2YT87(`[5K_3QI)%/=7YZ]XU39H(BN[ +M@%PP-*)N+:D"$6QL[AHRP``;EQVZ.RN2IO][WV,79+4]KG>(UW8^B<+NO)GW +MYGV;F3>\D3)]S/UTQLB8^QM/@PRBD,_3IUG(FXN?,VR8&<O*6ME<-EO8R)A6 +M/GNP`?DGDB>!,%#<!]BXX9[X.[IE[;.)S#Y_$KQ9M/_)VW+US&ZLF@?IXR"7 +M^[[]K=P#^V?S5GX#UJ+$W]S^%>!#X!!;'GJ.*]ASRZ2Q/B3B_Z)<K;RQ&\T5 +M\U@6_R8F^P?Q?W!0T/&_#K0=;[\G99O[QLAEQZ'C=HWZ.8OS`7.=]CZZR/XQ +MM0\3CW<!F_D+N[3+IQ<V4R)0-,R%W2P;DZ&K,\G_'HGX)_,^`8\?W_]ELYF< +MWO^M`X_L3^&]8AX_;O]<QBIH^Z\#W[1_E-Y7QF/9^F\5'J[_>=/,Z?5_'=AV +MO(X;=@5LV==-^[)J#+;8_;N1\-WDF^O&U3&]81>UTZMS&TJ`#E,LHL=L;M;+ +M)^_*9\EWC#F>8D[0$K?"VW&\4:AVV2:^`\+TF=&WD]JI762;EW;S??D<1XA( +MX1584"I!9O=P2E6[:M:OFG,ZO;_XS_AN_(^&*^.Q)/XM*U=X&/\93`DZ_M>` +M$>_<\+Z81^PA"P,!@?*=CCIDS!>?0L<78-^-I*\$-L_>G$X\?BYY5\1=;KD? +MP*?Q#AQ5&F5X95_7:Y?-5K-\UH"C^*'V;O857KZW+QN56A4PL-FT1XDZS]@L +MC$X$VU!18AB`DB"F%)@X\'N'NZY`KAX?B@`G(J`]@:[H\=!5!E2E$D7H2O"D +MBKOA0%/:!3H8.VH@,=-PN!7^!/I2=L$7/)">`5<XKWO9'2]0@G<-'.4T&C5P +MAB-W,I,)I8&)#'T8A6W7Z4`O]#K*D5ZP/Q3(HQOL=_!!<4\%!LVI.7`"ZB3' +M`4K3<;G/B7R3M'G=:.)9"E)%;$\=D@)Z-/9L.IX075#8?P^&\M;Q^O3@]7$< +M-$U'H4Q3!<VT+?T%&^!@8P=%#?BM@*$82G]BL(2],/M"BAA#Z37\279AFVP7 +M/D;&NE<(T1U]AI<+?3]/^WV!+XNTD6UIC$,V-WP)4I1S<'*L+:5"C^.CN1?. +M_6-J_+HO7/*%+L2*1"O!0/@"U6@>LE;+KIZV6DAXC'1C0*T&*FRCKCKA4'AJ +MJE7HH1*FUAG*;N@*`SZ@.MM"D;>)KH,NI5XP5AJ@A4VHEO$TRV(CI*&.RR!: +M60DOF`W5=OG@_M^\8^-#M59O5!H,EZM[.]+B]9T.IW;CY+)2;^)<&6M\6^QH +MD#WHH%\JU`)Z[\"Z"PR,"G"EO`G`=6X$NH!@/$0%^2![]+0@\IACF(B^Z_1Q +M9!">#/L#"B=7D!<0+:F,A1ZI0J"/L^.$O$8LL!7'`V-5Z27BC<VG5+YJOJU= +M,E;&`#+0RZ6_!]P(#9+LB!M][O*[B='#-8;^^)A/[M5GVU`^;]08HYW'CKE+ +M?#NX17CN-/G+(EG_B^LV*^:Q;/^?S68?G?\R>OU?"]+I-&Q_*%^<%TTCPVAU +M+$+L$PP71$H>12#GB%-+$5-9&GX@M'F;4GM'%?]!%L55$QM1@M"[\>388YBM +MA$\YK]6>%.%BFKEQ@:`J)<32H7#60>8/<V^^DM-LJ%CYW*K]*9"(_[A^NVH> +MR^(_4WA<_\GI^O]:<&R?5:KP&48^G<FW3,,P__*VX$NTJ;\_%<3M\@:H_5`' +MUR^"1/S39=`3\/A7]7_]^X^UX)']YY>!J^.Q-/_G\H_KOY;._^O`]HO],/"G +MEJ<C%YLE^L@-,-'3"?NYA=1X,B3B/[K&7SF/I?%O/3S_97.FJ>-_'8A__Q59 +M7O_\Z[=#(OYG/_]9,8]E\6_EOG'_K^L_:P&=\A)U%5SQAQ-XV9[66$K@B?&# +MN@L#V*'+V*B.WJ*2$=T3I&9GQ=0>M08=WQFI%B64(+I&2"5VERGX2'1T2Q#Q +M2K^.RMNMZ5,KZJ^W'AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH: ++R_`55?+KB0!0```` diff --git a/lib/CPANPLUS/t/inc/conf.pl b/lib/CPANPLUS/t/inc/conf.pl new file mode 100644 index 0000000000..7ca87471af --- /dev/null +++ b/lib/CPANPLUS/t/inc/conf.pl @@ -0,0 +1,173 @@ +BEGIN { + use FindBin; + use File::Spec; + + ### paths to our own 'lib' and 'inc' dirs + ### include them, relative from t/ + my @paths = map { "$FindBin::Bin/$_" } qw[../lib inc]; + + ### absolute'ify the paths in @INC; + my @rel2abs = map { File::Spec->rel2abs( $_ ) } + grep { not File::Spec->file_name_is_absolute( $_ ) } @INC; + + ### use require to make devel::cover happy + require lib; + for ( @paths, @rel2abs ) { + my $l = 'lib'; + $l->import( $_ ) + } + + use Config; + + ### and add them to the environment, so shellouts get them + $ENV{'PERL5LIB'} = join ':', + grep { defined } $ENV{'PERL5LIB'}, @paths, @rel2abs; + + ### add our own path to the front of $ENV{PATH}, so that cpanp-run-perl + ### and friends get picked up + $ENV{'PATH'} = join $Config{'path_sep'}, + grep { defined } "$FindBin::Bin/../bin", $ENV{'PATH'}; + + ### Fix up the path to perl, as we're about to chdir + ### but only under perlcore, or if the path contains delimiters, + ### meaning it's relative, but not looked up in your $PATH + $^X = File::Spec->rel2abs( $^X ) + if $ENV{PERL_CORE} or ( $^X =~ m|[/\\]| ); + + ### chdir to our own test dir, so we know all files are relative + ### to this point, no matter whether run from perlcore tests or + ### regular CPAN installs + chdir "$FindBin::Bin" if -d "$FindBin::Bin" +} + +BEGIN { + use IPC::Cmd; + + ### Win32 has issues with redirecting FD's properly in IPC::Run: + ### Can't redirect fd #4 on Win32 at IPC/Run.pm line 2801 + $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32'; + $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32'; +} + +use strict; +use CPANPLUS::Configure; + +use File::Path qw[rmtree]; +use FileHandle; +use File::Basename qw[basename]; + +{ ### Force the ignoring of .po files for L::M::S + $INC{'Locale::Maketext::Lexicon.pm'} = __FILE__; + $Locale::Maketext::Lexicon::VERSION = 0; +} + +# prereq has to be in our package file && core! +use constant TEST_CONF_PREREQ => 'Cwd'; +use constant TEST_CONF_MODULE => 'Foo::Bar::EU::NOXS'; +use constant TEST_CONF_INST_MODULE => 'Foo::Bar'; +use constant TEST_CONF_INVALID_MODULE => 'fnurk'; + +### we might need this Some Day when we're installing into +### our own sandbox. see t/20.t for details +# use constant TEST_INSTALL_DIR => do { +# my $dir = File::Spec->rel2abs( 'dummy-perl' ); +# +# ### clean up paths if we are on win32 +# ### dirs with spaces will be.. bad :( +# $^O eq 'MSWin32' +# ? Win32::GetShortPathName( $dir ) +# : $dir; +# }; + +# use constant TEST_INSTALL_DIR_LIB +# => File::Spec->catdir( TEST_INSTALL_DIR, 'lib' ); +# use constant TEST_INSTALL_DIR_BIN +# => File::Spec->catdir( TEST_INSTALL_DIR, 'bin' ); +# use constant TEST_INSTALL_DIR_MAN1 +# => File::Spec->catdir( TEST_INSTALL_DIR, 'man', 'man1' ); +# use constant TEST_INSTALL_DIR_MAN3 +# => File::Spec->catdir( TEST_INSTALL_DIR, 'man', 'man3' ); +# use constant TEST_INSTALL_DIR_ARCH +# => File::Spec->catdir( TEST_INSTALL_DIR, 'arch' ); +# +# use constant TEST_INSTALL_EU_MM_FLAGS => +# ' INSTALLDIRS=site' . +# ' INSTALLSITELIB=' . TEST_INSTALL_DIR_LIB . +# ' INSTALLSITEARCH=' . TEST_INSTALL_DIR_ARCH . # .packlist +# ' INSTALLARCHLIB=' . TEST_INSTALL_DIR_ARCH . # perllocal.pod +# ' INSTALLSITEBIN=' . TEST_INSTALL_DIR_BIN . +# ' INSTALLSCRIPT=' . TEST_INSTALL_DIR_BIN . +# ' INSTALLSITEMAN1DIR=' . TEST_INSTALL_DIR_MAN1 . +# ' INSTALLSITEMAN3DIR=' . TEST_INSTALL_DIR_MAN3; + + +sub gimme_conf { + my $conf = CPANPLUS::Configure->new(); + $conf->set_conf( hosts => [ { + path => 'dummy-CPAN', + scheme => 'file', + } ], + ); + $conf->set_conf( base => 'dummy-cpanplus' ); + $conf->set_conf( dist_type => '' ); + $conf->set_conf( signature => 0 ); + + _clean_test_dir( [ + $conf->get_conf('base'), +# TEST_INSTALL_DIR_LIB, +# TEST_INSTALL_DIR_BIN, +# TEST_INSTALL_DIR_MAN1, +# TEST_INSTALL_DIR_MAN3, + ], 1 ); + + return $conf; +}; + +my $fh; +my $file = ".".basename($0).".output"; +sub output_handle { + return $fh if $fh; + + $fh = FileHandle->new(">$file") + or warn "Could not open output file '$file': $!"; + + $fh->autoflush(1); + return $fh; +} + +sub output_file { return $file } + +### whenever we start a new script, we want to clean out our +### old files from the test '.cpanplus' dir.. +sub _clean_test_dir { + my $dirs = shift || []; + my $verbose = shift || 0; + + for my $dir ( @$dirs ) { + + my $dh; + opendir $dh, $dir or die "Could not open basedir '$dir': $!"; + while( my $file = readdir $dh ) { + next if $file =~ /^\./; # skip dot files + + my $path = File::Spec->catfile( $dir, $file ); + + ### directory, rmtree it + if( -d $path ) { + print "Deleting directory '$path'\n" if $verbose; + eval { rmtree( $path ) }; + warn "Could not delete '$path' while cleaning up '$dir'" if $@; + + ### regular file + } else { + print "Deleting file '$path'\n" if $verbose; + 1 while unlink $path; + } + } + + close $dh; + } + + return 1; +} +1; @@ -23,6 +23,9 @@ utils/pl2pm utils/prove utils/ptar utils/ptardiff +utils/cpanp-run-perl +utils/cpanp +utils/cpan2dist utils/shasum utils/splain utils/xsubpp diff --git a/utils/Makefile b/utils/Makefile index a37a5708ff..3a96c9e8a0 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -5,9 +5,9 @@ REALPERL = ../perl # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL config_data.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL shasum.PL splain.PL dprofpp.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL -plextract = c2ph config_data corelist cpan h2ph h2xs instmodsh perlbug perldoc perlivp pl2pm prove ptar ptardiff shasum splain dprofpp libnetcfg piconv enc2xs xsubpp -plextractexe = ./c2ph ./config_data ./corelist ./cpan ./h2ph ./h2xs ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./shasum ./splain ./dprofpp ./libnetcfg ./piconv ./enc2xs ./xsubpp +pl = c2ph.PL config_data.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL cpanp-run-perl.PL cpanp.PL cpan2dist.PL shasum.PL splain.PL dprofpp.PL libnetcfg.PL piconv.PL enc2xs.PL xsubpp.PL +plextract = c2ph config_data corelist cpan h2ph h2xs instmodsh perlbug perldoc perlivp pl2pm prove ptar ptardiff cpanp-run-perl cpanp cpan2dist shasum splain dprofpp libnetcfg piconv enc2xs xsubpp +plextractexe = ./c2ph ./config_data ./corelist ./cpan ./h2ph ./h2xs ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./cpanp-run-perl ./cpanp ./cpan2dist ./shasum ./splain ./dprofpp ./libnetcfg ./piconv ./enc2xs ./xsubpp all: $(plextract) @@ -40,6 +40,12 @@ ptar: ptar.PL ../config.sh ptardiff: ptardiff.PL ../config.sh +cpanp-run-perl: cpanp-run-perl.PL ../config.sh + +cpanp: cpanp.PL ../config.sh + +cpan2dist: cpan2dist.PL ../config.sh + pl2pm: pl2pm.PL ../config.sh shasum: shasum.PL ../config.sh diff --git a/utils/cpan2dist.PL b/utils/cpan2dist.PL new file mode 100644 index 0000000000..93a670989e --- /dev/null +++ b/utils/cpan2dist.PL @@ -0,0 +1,51 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +my $origdir = cwd; +chdir dirname($0); +my $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +use File::Spec; + +my $script = File::Spec->catfile( + File::Spec->catdir( + File::Spec->updir, qw[ lib CPANPLUS bin ] + ), "cpan2dist"); + +if (open(IN, $script)) { + print OUT <IN>; + close IN; +} else { + die "$0: cannot find '$script'\n"; +} + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/utils/cpanp-run-perl.PL b/utils/cpanp-run-perl.PL new file mode 100644 index 0000000000..fe588f5173 --- /dev/null +++ b/utils/cpanp-run-perl.PL @@ -0,0 +1,51 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +my $origdir = cwd; +chdir dirname($0); +my $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +use File::Spec; + +my $script = File::Spec->catfile( + File::Spec->catdir( + File::Spec->updir, qw[ lib CPANPLUS bin ] + ), "cpanp-run-perl"); + +if (open(IN, $script)) { + print OUT <IN>; + close IN; +} else { + die "$0: cannot find '$script'\n"; +} + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/utils/cpanp.PL b/utils/cpanp.PL new file mode 100644 index 0000000000..932337b711 --- /dev/null +++ b/utils/cpanp.PL @@ -0,0 +1,51 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); +use Cwd; + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +my $origdir = cwd; +chdir dirname($0); +my $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +use File::Spec; + +my $script = File::Spec->catfile( + File::Spec->catdir( + File::Spec->updir, qw[ lib CPANPLUS bin ] + ), "cpanp"); + +if (open(IN, $script)) { + print OUT <IN>; + close IN; +} else { + die "$0: cannot find '$script'\n"; +} + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir; diff --git a/win32/Makefile b/win32/Makefile index 1de959fbaf..e1f15a48d7 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -593,6 +593,9 @@ UTILS = \ ..\utils\prove \ ..\utils\ptar \ ..\utils\ptardiff \ + ..\utils\cpanp-run-perl \ + ..\utils\cpanp \ + ..\utils\cpan2dist \ ..\utils\shasum \ ..\utils\instmodsh \ ..\pod\checkpods \ @@ -1160,7 +1163,7 @@ distclean: realclean podchecker podselect -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ perldoc perlivp dprofpp libnetcfg enc2xs piconv cpan *.bat \ - xsubpp instmodsh prove ptar ptardiff shasum corelist config_data + xsubpp instmodsh prove ptar ptardiff cpanp-run-perl cpanp cpan2dist shasum corelist config_data -cd ..\x2p && del /f find2perl s2p psed *.bat -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new \ perlmainst.c diff --git a/win32/makefile.mk b/win32/makefile.mk index e5f6bc6f94..966aa7478b 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -746,6 +746,9 @@ UTILS = \ ..\utils\prove \ ..\utils\ptar \ ..\utils\ptardiff \ + ..\utils\cpanp-run-perl \ + ..\utils\cpanp \ + ..\utils\cpan2dist \ ..\utils\shasum \ ..\utils\instmodsh \ ..\pod\checkpods \ @@ -1487,7 +1490,7 @@ distclean: realclean podchecker podselect -cd ..\utils && del /f h2ph splain perlbug pl2pm c2ph pstruct h2xs \ perldoc perlivp dprofpp libnetcfg enc2xs piconv cpan *.bat \ - xsubpp instmodsh prove ptar ptardiff shasum corelist config_data + xsubpp instmodsh prove ptar ptardiff cpanp-run-perl cpanp cpan2dist shasum corelist config_data -cd ..\x2p && del /f find2perl s2p psed *.bat -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new \ perlmainst.c |