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
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
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
# 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
--- /dev/null
+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:
--- /dev/null
+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
+
+
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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:
+
--- /dev/null
+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;
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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;
--- /dev/null
+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:
--- /dev/null
+=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
+
--- /dev/null
+=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
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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;
--- /dev/null
+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:
--- /dev/null
+package CPANPLUS::Internals::Utils::Autoflush;
+
+BEGIN { $|++ };
+
+1;
--- /dev/null
+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();
--- /dev/null
+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:
--- /dev/null
+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:
--- /dev/null
+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;
--- /dev/null
+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:
--- /dev/null
+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;
--- /dev/null
+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:
--- /dev/null
+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:
+
--- /dev/null
+##################################################
+### 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:
--- /dev/null
+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 ###
--- /dev/null
+=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:
+
--- /dev/null
+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:
+
--- /dev/null
+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:
+
--- /dev/null
+#!/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:
--- /dev/null
+#!/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:
--- /dev/null
+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
--- /dev/null
+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:
+
--- /dev/null
+### 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" );
+ }
+}
+
+
+
+
--- /dev/null
+### 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:
+
--- /dev/null
+### 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:
--- /dev/null
+### 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:
--- /dev/null
+### 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:
--- /dev/null
+### 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:
--- /dev/null
+### 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:
--- /dev/null
+### 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:
--- /dev/null
+### 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:
--- /dev/null
+### 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:
+
--- /dev/null
+### 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:
--- /dev/null
+### 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:
--- /dev/null
+### 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:
--- /dev/null
+### 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:
+
+
--- /dev/null
+### 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() }
--- /dev/null
+### 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" );
+ }
+}
+
--- /dev/null
+### 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:
--- /dev/null
+#########################################################################
+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!
+"````
--- /dev/null
+#########################################################################
+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['`"@`````
--- /dev/null
+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-----
--- /dev/null
+#########################################################################
+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`%``````
--- /dev/null
+#########################################################################
+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````
--- /dev/null
+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-----
--- /dev/null
+#########################################################################
+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````
--- /dev/null
+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-----
--- /dev/null
+#########################################################################
+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```
--- /dev/null
+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-----
--- /dev/null
+#########################################################################
+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````
--- /dev/null
+#########################################################################
+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,`````
--- /dev/null
+#########################################################################
+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,`````
--- /dev/null
+#########################################################################
+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!
+"````
--- /dev/null
+#########################################################################
+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,`````
--- /dev/null
+#########################################################################
+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,`````
--- /dev/null
+#########################################################################
+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['`"@`````
--- /dev/null
+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-----
--- /dev/null
+#########################################################################
+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`%``````
--- /dev/null
+#########################################################################
+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````
--- /dev/null
+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-----
--- /dev/null
+#########################################################################
+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````
--- /dev/null
+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-----
--- /dev/null
+#########################################################################
+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```
--- /dev/null
+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-----
--- /dev/null
+#########################################################################
+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````
--- /dev/null
+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;
utils/prove
utils/ptar
utils/ptardiff
+utils/cpanp-run-perl
+utils/cpanp
+utils/cpan2dist
utils/shasum
utils/splain
utils/xsubpp
# 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)
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
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
..\utils\prove \
..\utils\ptar \
..\utils\ptardiff \
+ ..\utils\cpanp-run-perl \
+ ..\utils\cpanp \
+ ..\utils\cpan2dist \
..\utils\shasum \
..\utils\instmodsh \
..\pod\checkpods \
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
..\utils\prove \
..\utils\ptar \
..\utils\ptardiff \
+ ..\utils\cpanp-run-perl \
+ ..\utils\cpanp \
+ ..\utils\cpan2dist \
..\utils\shasum \
..\utils\instmodsh \
..\pod\checkpods \
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
projects / p5sagit/p5-mst-13.2.git / commitdiff