From: Rafael Garcia-Suarez Date: Wed, 10 Oct 2007 15:36:53 +0000 (+0000) Subject: Update CPANPLUS to 0.83_02 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5bc5f6dcbaef1be54e82568ecec8132658cc613e;p=p5sagit%2Fp5-mst-13.2.git Update CPANPLUS to 0.83_02 p4raw-id: //depot/perl@32092 --- diff --git a/MANIFEST b/MANIFEST index 7a48bee..ef5ba5e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1614,6 +1614,7 @@ 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/CustomSource.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 @@ -1638,20 +1639,20 @@ 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/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.readme CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz.packed CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme CPANPLUS tests +lib/CPANPLUS/t/dummy-CPAN/authors/id/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/inc/conf.pl CPANPLUS tests diff --git a/lib/CPANPLUS.pm b/lib/CPANPLUS.pm index 52595d2..22cd8d0 100644 --- a/lib/CPANPLUS.pm +++ b/lib/CPANPLUS.pm @@ -13,7 +13,7 @@ BEGIN { use vars qw( @EXPORT @ISA $VERSION ); @EXPORT = qw( shell fetch get install ); @ISA = qw( Exporter ); - $VERSION = "0.82"; #have to hardcode or cpan.org gets unhappy + $VERSION = "0.83_02"; #have to hardcode or cpan.org gets unhappy } ### purely for backward compatibility, so we can call it from the commandline: diff --git a/lib/CPANPLUS/Backend.pm b/lib/CPANPLUS/Backend.pm index 32ed716..8752b71 100644 --- a/lib/CPANPLUS/Backend.pm +++ b/lib/CPANPLUS/Backend.pm @@ -39,7 +39,7 @@ CPANPLUS::Backend =head1 SYNOPSIS - my $cb = CPANPLUS::Backend->new( ); + my $cb = CPANPLUS::Backend->new; my $conf = $cb->configure_object; my $author = $cb->author_tree('KANE'); @@ -172,7 +172,7 @@ sub author_tree { =pod -=head2 $conf = $cb->configure_object () +=head2 $conf = $cb->configure_object; Returns a copy of the C object. @@ -475,6 +475,19 @@ sub parse_module { ### usual mirrors $modobj->status->_fetch_from( $mod ); + ### better guess for the version + $modobj->version( $modobj->package_version ) + if defined $modobj->package_version; + + ### better guess at module name, if possible + if ( my $pkgname = $modobj->package_name ) { + $pkgname =~ s/-/::/g; + + ### no sense replacing it unless we changed something + $modobj->module( $pkgname ) + if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/; + } + return $modobj; } @@ -798,9 +811,9 @@ 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. +Enable/disable fetching of index files. You can disable fetching of the +index files if you don't plan to use the local mirror as your primary +site, or if you'd like up-to-date index files be fetched from elsewhere. Defaults to true. @@ -965,6 +978,10 @@ sub autobundle { error( loc( "Could not open '%1' for writing: %2", $file, $! ) ); return; } + + ### make sure we load the module tree *before* doing this, as it + ### starts to chdir all over the place + $self->module_tree; my $string = join "\n\n", map { @@ -1018,6 +1035,131 @@ EOF return $file; } +### XXX these wrappers are not individually tested! only the underlying +### code through source.t and indirectly trought he CustomSource plugin. +=pod + +=head1 CUSTOM MODULE SOURCES + +Besides the sources as provided by the general C mirrors, it's +possible to add your own sources list to your C index. + +The methodology behind this works much like C. + +The methods below show you how to make use of this functionality. Also +note that most of these methods are available through the default shell +plugin command C, making them available as shortcuts through the +shell and via the commandline. + +=head2 %files = $cb->list_custom_sources + +Returns a mapping of registered custom sources and their local indices +as follows: + + /full/path/to/local/index => http://remote/source + +Note that any file starting with an C<#> is being ignored. + +=cut + +sub list_custom_sources { + return shift->__list_custom_module_sources( @_ ); +} + +=head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] ); + +Adds an C to your own sources list and mirrors its index. See the +documentation on C<< $cb->update_custom_source >> on how this is done. + +Returns the full path to the local index on success, or false on failure. + +Note that when adding a new C, the change to the in-memory tree is +not saved until you rebuild or save the tree to disk again. You can do +this using the C<< $cb->reload_indices >> method. + +=cut + +sub add_custom_source { + return shift->_add_custom_module_source( @_ ); +} + +=head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] ); + +Removes an C from your own sources list and removes its index. + +To find out what Cs you have as part of your own sources list, use +the C<< $cb->list_custom_sources >> method. + +Returns the full path to the deleted local index file on success, or false +on failure. + +=cut + +### XXX do clever dispatching based on arg number? +sub remove_custom_source { + return shift->_remove_custom_module_source( @_ ); +} + +=head2 $bool = $cb->update_custom_source( [remote => URI] ); + +Updates the indexes for all your custom sources. It does this by fetching +a file called C in the root of the custom sources's C. +If you provide the C argument, it will only update the index for +that specific C. + +Here's an example of how custom sources would resolve into index files: + + file:///path/to/sources => file:///path/to/sources/packages.txt + http://example.com/sources => http://example.com/sources/packages.txt + ftp://example.com/sources => ftp://example.com/sources/packages.txt + +The file C simply holds a list of packages that can be found +under the root of the C. This file can be automatically generated for +you when the remote source is a C. For C, C, +and similar, the administrator of that repository should run the method +C<< $cb->write_custom_source_index >> on the repository to allow remote +users to index it. + +For details, see the C<< $cb->write_custom_source_index >> method below. + +All packages that are added via this mechanism will be attributed to the +author with C C. You can use this id to search for all +added packages. + +=cut + +sub update_custom_source { + my $self = shift; + + ### if it mentions /remote/, the request is to update a single uri, + ### not all the ones we have, so dispatch appropriately + my $rv = grep( /remote/i, @_) + ? $self->__update_custom_module_source( @_ ) + : $self->__update_custom_module_sources( @_ ); + + return $rv; +} + +=head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] ); + +Writes the index for a custom repository root. Most users will not have to +worry about this, but administrators of a repository will need to make sure +their indexes are up to date. + +The index will be written to a file called C in your repository +root, which you can specify with the C argument. You can override this +location by specifying the C argument, but in normal operation, that should +not be required. + +Once the index file is written, users can then add the C pointing to +the repository to their custom list of sources and start using it right away. See the C<< $cb->add_custom_source >> method for user details. + +=cut + +sub write_custom_source_index { + return shift->__write_custom_module_index( @_ ); +} + 1; =pod @@ -1040,7 +1182,8 @@ under the same terms as Perl itself. =head1 SEE ALSO -L, L, L +L, L, L, +L =cut diff --git a/lib/CPANPLUS/Config.pm b/lib/CPANPLUS/Config.pm index fe17881..b092133 100644 --- a/lib/CPANPLUS/Config.pm +++ b/lib/CPANPLUS/Config.pm @@ -54,7 +54,8 @@ my $Conf = { 'stored' => 'sourcefiles', 'dslip' => '03modlist.data.gz', 'update' => '86400', - 'mod' => '02packages.details.txt.gz' + 'mod' => '02packages.details.txt.gz', + 'custom_index' => 'packages.txt', }, '_build' => { 'plugins' => 'plugins', @@ -65,6 +66,7 @@ my $Conf = { 'autobundle_prefix' => 'Snapshot', 'autdir' => 'authors', 'install_log_dir' => 'install-logs', + 'custom_sources' => 'custom-sources', 'sanity_check' => 1, }, '_mirror' => { diff --git a/lib/CPANPLUS/Internals.pm b/lib/CPANPLUS/Internals.pm index 7d02eeb..f57facc 100644 --- a/lib/CPANPLUS/Internals.pm +++ b/lib/CPANPLUS/Internals.pm @@ -40,7 +40,7 @@ use vars qw[@ISA $VERSION]; CPANPLUS::Internals::Report ]; -$VERSION = "0.82"; +$VERSION = "0.83_02"; =pod diff --git a/lib/CPANPLUS/Internals/Constants.pm b/lib/CPANPLUS/Internals/Constants.pm index 01dc706..00bf2c5 100644 --- a/lib/CPANPLUS/Internals/Constants.pm +++ b/lib/CPANPLUS/Internals/Constants.pm @@ -4,6 +4,7 @@ use strict; use CPANPLUS::Error; +use Config; use File::Spec; use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; @@ -39,7 +40,13 @@ 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 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 DOT_CPANPLUS => ON_VMS ? '_cpanplus' : '.cpanplus'; use constant OPT_AUTOFLUSH => '-MCPANPLUS::Internals::Utils::Autoflush'; @@ -109,16 +116,23 @@ use constant DIR_EXISTS => sub { $dir)); return; }; - + + ### On VMS, if the $Config{make} is either MMK + ### or MMS, then the makefile is 'DESCRIP.MMS'. +use constant MAKEFILE => sub { my $file = + (ON_VMS and + $Config::Config{make} =~ /MM[S|K]/i) + ? 'DESCRIP.MMS' + : 'Makefile'; + + return @_ + ? File::Spec->catfile( @_, $file ) + : $file; + }; 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( @_, @@ -199,7 +213,29 @@ use constant OPEN_FILE => sub { return $fh if $fh; return; }; - + +use constant OPEN_DIR => sub { + my $dir = shift; + my $dh; + opendir $dh, $dir or error(loc( + "Could not open dir '%1': %2", $dir, $! + )); + + return $dh if $dh; + return; + }; + +use constant READ_DIR => sub { + my $dir = shift; + my $dh = OPEN_DIR->( $dir ) or return; + + ### exclude . and .. + my @files = grep { $_ !~ /^\.{1,2}/ } + readdir($dh); + + return @files; + }; + use constant STRIP_GZ_SUFFIX => sub { my $file = $_[0] or return; @@ -236,6 +272,9 @@ use constant CREATE_FILE_URI : 'file://' . $dir; }; +use constant CUSTOM_AUTHOR_ID + => 'LOCAL'; + use constant DOT_SHELL_DEFAULT_RC => '.shell-default.rc'; @@ -269,11 +308,6 @@ use constant INSTALL_LOG_FILE 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; ". diff --git a/lib/CPANPLUS/Internals/Extract.pm b/lib/CPANPLUS/Internals/Extract.pm index 881ec7b..8063b90 100644 --- a/lib/CPANPLUS/Internals/Extract.pm +++ b/lib/CPANPLUS/Internals/Extract.pm @@ -199,9 +199,14 @@ sub _extract { ### 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 ), + for my $try ( + File::Spec->rel2abs( + $self->_safe_path( path => + File::Spec->catdir( $to, + $mod->package_name .'-'. + $mod->package_version + ) ) ), + File::Spec->rel2abs( $ae->extract_path ), ) { ($dir = $try) && last if -d $try; } diff --git a/lib/CPANPLUS/Internals/Report.pm b/lib/CPANPLUS/Internals/Report.pm index ffcb4f0..cbe20a6 100644 --- a/lib/CPANPLUS/Internals/Report.pm +++ b/lib/CPANPLUS/Internals/Report.pm @@ -9,8 +9,8 @@ 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]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; $Params::Check::VERBOSE = 1; @@ -53,16 +53,14 @@ otherwise. =cut { my $query_list = { - LWP => '0.0', - 'LWP::UserAgent' => '0.0', - 'HTTP::Request' => '0.0', - URI => '0.0', - YAML => '0.0', + 'File::Fetch' => '0.08', + 'YAML::Tiny' => '0.0', + 'File::Temp' => '0.0', }; my $send_list = { %$query_list, - 'Test::Reporter' => 1.27, + 'Test::Reporter' => '1.34', }; sub _have_query_report_modules { @@ -158,27 +156,41 @@ sub _query_report { ### 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->() ); + ### XXX no longer use LWP here. However, that means we don't + ### automagically set proxies anymore!!! + # my $ua = LWP::UserAgent->new; + # $ua->agent( CPANPLUS_UA->() ); + # ### set proxies if we have them ### - $ua->env_proxy(); + # $ua->env_proxy(); my $url = TESTERS_URL->($mod->package_name); - my $req = HTTP::Request->new( GET => $url); + my $ff = File::Fetch->new( uri => $url ); msg( loc("Fetching: '%1'", $url), $verbose ); - my $res = $ua->request( $req ); + my $res = do { + my $tempdir = File::Temp::tempdir(); + my $where = $ff->fetch( to => $tempdir ); + + unless( $where ) { + error( loc( "Fetching report for '%1' failed: %2", + $url, $ff->error ) ); + return; + } - unless( $res->is_success ) { - error( loc( "Fetching report for '%1' failed: %2", - $url, $res->message ) ); - return; - } + my $fh = OPEN_FILE->( $where ); + + do { local $/; <$fh> }; + }; + + my ($aref) = eval { YAML::Tiny::Load( $res ) }; - my $aref = YAML::Load( $res->content ); + if( $@ ) { + error(loc("Error reading result: %1", $@)); + return; + }; my $dist = $mod->package_name .'-'. $mod->package_version; @@ -439,7 +451,7 @@ sub _send_report { $message .= REPORT_LOADED_PREREQS->($mod); ### the footer - $message .= REPORT_MESSAGE_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 @@ -479,12 +491,15 @@ sub _send_report { } } } + + msg( loc("Sending test report for '%1'", $dist), $verbose); ### reporter object ### my $reporter = Test::Reporter->new( grade => $grade, distribution => $dist, via => "CPANPLUS $int_ver", + timeout => $conf->get_conf('timeout') || 60, debug => $conf->get_conf('debug'), ); diff --git a/lib/CPANPLUS/Internals/Search.pm b/lib/CPANPLUS/Internals/Search.pm index 30443f0..2a711ab 100644 --- a/lib/CPANPLUS/Internals/Search.pm +++ b/lib/CPANPLUS/Internals/Search.pm @@ -256,15 +256,19 @@ sub _all_installed { my $conf = $self->configure_object; my %hash = @_; - my %seen; my @rv; - + ### File::Find uses follow_skip => 1 by default, which doesn't die + ### on duplicates, unless they are directories or symlinks. + ### Ticket #29796 shows this code dying on Alien::WxWidgets, + ### which uses symlinks. + ### File::Find doc says to use follow_skip => 2 to ignore duplicates + ### so this will stop it from dying. + my %find_args = ( follow_skip => 2 ); ### 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'; + $find_args{'follow_fast'} = 1 unless ON_WIN32; ### never use the @INC hooks to find installed versions of ### modules -- they're just there in case they're not on the @@ -273,34 +277,73 @@ sub _all_installed { ### XXX CPANPLUS::inc is now obsolete, remove the calls #local @INC = CPANPLUS::inc->original_inc; + my %seen; my @rv; for my $dir (@INC ) { next if $dir eq '.'; - ### not a directory after all ### + ### not a directory after all + ### may be coderef or some such 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( + + ### John M. notes: On VMS cannonpath can not currently handle + ### the $dir values that are in UNIX format. + $dir = File::Spec->canonpath( $dir ) unless ON_VMS; + + ### have to use F::S::Unix on VMS, or things will break + my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec'; + + ### XXX in some cases File::Find can actually die! + ### so be safe and wrap it in an eval. + eval { File::Find::find( { %find_args, wanted => sub { return unless /\.pm$/i; my $mod = $File::Find::name; + ### make sure it's in Unix format, as it + ### may be in VMS format on VMS; + $mod = VMS::Filespec::unixify( $mod ) if ON_VMS; + $mod = substr($mod, length($dir) + 1, -3); - $mod = join '::', File::Spec->splitdir($mod); + $mod = join '::', $file_spec->splitdir($mod); return if $seen{$mod}++; - my $modobj = $self->module_tree($mod) or return; + + ### From John Malmberg: This is failing on VMS + ### because ODS-2 does not retain the case of + ### filenames that are created. + ### The problem is the filename is being converted + ### to a module name and then looked up in the + ### %$modtree hash. + ### + ### As a fix, we do a search on VMS instead -- + ### more cpu cycles, but it gets around the case + ### problem --kane + my ($modobj) = do { + ON_VMS + ? $self->search( + type => 'module', + allow => [qr/^$mod$/i], + ) + : $self->module_tree($mod) + }; + + ### seperate return, a list context return with one '' + ### in it, is also true! + return unless $modobj; push @rv, $modobj; }, }, $dir - ); + ) }; + + ### report the error if file::find died + error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@; } return \@rv; diff --git a/lib/CPANPLUS/Internals/Source.pm b/lib/CPANPLUS/Internals/Source.pm index f527618..49e0653 100644 --- a/lib/CPANPLUS/Internals/Source.pm +++ b/lib/CPANPLUS/Internals/Source.pm @@ -8,12 +8,15 @@ use CPANPLUS::Module::Fake; use CPANPLUS::Module::Author; use CPANPLUS::Internals::Constants; +use File::Fetch; use Archive::Extract; -use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; -use Params::Check qw[check]; use IPC::Cmd qw[can_run]; +use File::Temp qw[tempdir]; +use File::Basename qw[dirname]; +use Params::Check qw[check]; use Module::Load::Conditional qw[can_load]; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; $Params::Check::VERBOSE = 1; @@ -42,9 +45,11 @@ well as update them, and then parse them. The flow looks like this: $cb->_author_tree || $cb->_module_tree - $cb->__check_trees + $cb->_check_trees $cb->__check_uptodate $cb->_update_source + $cb->__update_custom_module_sources + $cb->__update_custom_module_source $cb->_build_trees $cb->__create_author_tree $cb->__retrieve_source @@ -52,6 +57,7 @@ The flow looks like this: $cb->__retrieve_source $cb->__create_dslip_tree $cb->__retrieve_source + $cb->__create_custom_module_entries $cb->_save_source $cb->_dslip_defs @@ -162,6 +168,12 @@ sub _check_trees { } } + ### if we're explicitly asked to update the sources, or if the + ### standard source files are out of date, update the custom sources + ### as well + $self->__update_custom_module_sources( verbose => $verbose ) + if $update_source or !$uptodate; + return $uptodate; } @@ -228,8 +240,8 @@ sub __check_uptodate { 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! + 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; @@ -275,25 +287,23 @@ sub _update_source { my %hash = @_; my $conf = $self->configure_object; - + my $verbose; my $tmpl = { name => { required => 1 }, path => { default => $conf->get_conf('base') }, - verbose => { default => $conf->get_conf('verbose') }, + verbose => { default => $conf->get_conf('verbose'), store => \$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'} ); + msg( loc("Updating source file '%1'", $file), $verbose ); my $fake = CPANPLUS::Module::Fake->new( module => $args->{'name'}, @@ -316,15 +326,9 @@ sub _update_source { return; } - ### `touch` the file, so windoze knows it's new -jmb - ### works on *nix too, good fix -Kane - ### make sure it is writable first, otherwise the `touch` will fail - unless (chmod ( 0644, File::Spec->catfile($path, $file) ) && - utime ( $now, $now, File::Spec->catfile($path, $file) )) { - error( loc("Couldn't touch %1", $file) ); - } - + $self->_update_timestamp( file => File::Spec->catfile($path, $file) ); } + return 1; } @@ -400,6 +404,16 @@ sub _build_trees { ### return if we weren't able to build the trees ### return unless $self->{_modtree} && $self->{_authortree}; + ### update them if the other sources are also deemed out of date + unless( $uptodate ) { + $self->__update_custom_module_sources( verbose => $args->{verbose} ) + or error(loc("Could not update custom module sources")); + } + + ### add custom sources here + $self->__create_custom_module_entries( verbose => $args->{verbose} ) + or error(loc("Could not create custom module entries")); + ### 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 @@ -619,7 +633,7 @@ Returns a tree on success, false on failure. =cut -sub __create_author_tree() { +sub __create_author_tree { my $self = shift; my %hash = @_; my $conf = $self->configure_object; @@ -761,8 +775,8 @@ sub _create_mod_tree { ### 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}/ + m| (?:[A-Z\d-]/)? + (?:[A-Z\d-]{2}/)? ([A-Z\d-]+) (?:/[\S]+)?/ ([^/]+)$ |xsg; @@ -1004,6 +1018,436 @@ sub _dslip_defs { return $aref; } +=head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] ); + +Adds a custom source index and updates it based on the provided URI. + +Returns the full path to the index file on success or false on failure. + +=cut + +sub _add_custom_module_source { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$uri); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + uri => { required => 1, store => \$uri } + }; + + check( $tmpl, \%hash ) or return; + + my $index = File::Spec->catfile( + $conf->get_conf('base'), + $conf->_get_build('custom_sources'), + $self->_uri_encode( uri => $uri ), + ); + + ### already have it. + if( IS_FILE->( $index ) ) { + msg(loc("Source '%1' already added", $uri)); + return 1; + } + + ### do we need to create the targe dir? + { my $dir = dirname( $index ); + unless( IS_DIR->( $dir ) ) { + $self->_mkdir( dir => $dir ) or return + } + } + + ### write the file + my $fh = OPEN_FILE->( $index => '>' ) or do { + error(loc("Could not write index file for '%1'", $uri)); + return; + }; + + ### basically we 'touched' it. + close $fh; + + $self->__update_custom_module_source( + remote => $uri, + local => $index, + verbose => $verbose, + ) or do { + ### we faild to update it, we probably have an empty + ### possibly silly filename on disk now -- remove it + 1 while unlink $index; + return; + }; + + return $index; +} + +=head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] ); + +Removes a custom index file based on the URI provided. + +Returns the full path to the index file on success or false on failure. + +=cut + +sub _remove_custom_module_source { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$uri); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + uri => { required => 1, store => \$uri } + }; + + check( $tmpl, \%hash ) or return; + + ### use uri => local, instead of the other way around + my %files = reverse $self->__list_custom_module_sources; + + my $file = $files{ $uri } or do { + error(loc("No such custom source '%1'", $uri)); + return; + }; + + 1 while unlink $file; + + if( IS_FILE->( $file ) ) { + error(loc("Could not remove index file '%1' for custom source '%2'", + $file, $uri)); + return; + } + + msg(loc("Successfully removed index file for '%1'", $uri), $verbose); + + return $file; +} + +=head2 %files = $cb->__list_custom_module_sources + +This method scans the 'custom-sources' directory in your base directory +for additional sources to include in your module tree. + +Returns a list of key value pairs as follows: + + /full/path/to/source/file%3Fencoded => http://decoded/mirror/path + +=cut + +sub __list_custom_module_sources { + my $self = shift; + my $conf = $self->configure_object; + + my $dir = File::Spec->catdir( + $conf->get_conf('base'), + $conf->_get_build('custom_sources'), + ); + + unless( IS_DIR->( $dir ) ) { + msg(loc("No '%1' dir, skipping custom sources", $dir)); + return; + } + + ### unencode the files + ### skip ones starting with # though + my %files = map { + my $org = $_; + my $dec = $self->_uri_decode( uri => $_ ); + File::Spec->catfile( $dir, $org ) => $dec + } grep { $_ !~ /^#/ } READ_DIR->( $dir ); + + return %files; +} + +=head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] ); + +Attempts to update all the index files to your custom module sources. + +If the index is missing, and it's a C uri, it will generate +a new local index for you. + +Return true on success, false on failure. + +=cut + +sub __update_custom_module_sources { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $verbose; + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose } + }; + + check( $tmpl, \%hash ) or return; + + my %files = $self->__list_custom_module_sources; + + ### uptodate check has been done a few levels up. + my $fail; + while( my($local,$remote) = each %files ) { + + $self->__update_custom_module_source( + remote => $remote, + local => $local, + verbose => $verbose, + ) or ( $fail++, next ); + } + + error(loc("Failed updating one or more remote sources files")) if $fail; + + return if $fail; + return 1; +} + +=head2 $ok = $cb->__update_custom_module_source + +Attempts to update all the index files to your custom module sources. + +If the index is missing, and it's a C uri, it will generate +a new local index for you. + +Return true on success, false on failure. + +=cut + +sub __update_custom_module_source { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my($verbose,$local,$remote); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + local => { store => \$local, allow => FILE_EXISTS }, + remote => { required => 1, store => \$remote }, + }; + + check( $tmpl, \%hash ) or return; + + msg( loc("Updating sources from '%1'", $remote), $verbose); + + ### if you didn't provide a local file, we'll look in your custom + ### dir to find the local encoded version for you + $local ||= do { + ### find all files we know of + my %files = reverse $self->__list_custom_module_sources or do { + error(loc("No custom modules sources defined -- need '%1' argument", + 'local')); + return; + }; + + ### return the local file we're supposed to use + $files{ $remote } or do { + error(loc("Remote source '%1' unknown -- needs '%2' argument", + $remote, 'local')); + return; + }; + }; + + my $uri = join '/', $remote, $conf->_get_source('custom_index'); + my $ff = File::Fetch->new( uri => $uri ); + my $dir = tempdir(); + my $res = do { local $File::Fetch::WARN = 0; + local $File::Fetch::WARN = 0; + $ff->fetch( to => $dir ); + }; + + ### couldn't get the file + unless( $res ) { + + ### it's not a local scheme, so can't auto index + unless( $ff->scheme eq 'file' ) { + error(loc("Could not update sources from '%1': %2", + $remote, $ff->error )); + return; + + ### it's a local uri, we can index it ourselves + } else { + msg(loc("No index file found at '%1', generating one", + $ff->uri), $verbose ); + + $self->__write_custom_module_index( + path => File::Spec->catdir( + File::Spec::Unix->splitdir( $ff->path ) + ), + to => $local, + verbose => $verbose, + ) or return; + + ### XXX don't write that here, __write_custom_module_index + ### already prints this out + #msg(loc("Index file written to '%1'", $to), $verbose); + } + + ### copy it to the real spot and update it's timestamp + } else { + $self->_move( file => $res, to => $local ) or return; + $self->_update_timestamp( file => $local ); + + msg(loc("Index file saved to '%1'", $local), $verbose); + } + + return $local; +} + +=head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] ) + +Scans the C you provided for packages and writes an index with all +the available packages to C<$path/packages.txt>. If you'd like the index +to be written to a different file, provide the C argument. + +Returns true on success and false on failure. + +=cut + +sub __write_custom_module_index { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my ($verbose, $path, $to); + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), + store => \$verbose }, + path => { required => 1, allow => DIR_EXISTS, store => \$path }, + to => { store => \$to }, + }; + + check( $tmpl, \%hash ) or return; + + ### no explicit to? then we'll use our default + $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') ); + + my @files; + require File::Find; + File::Find::find( sub { + ### let's see if A::E can even parse it + my $ae = do { + local $Archive::Extract::WARN = 0; + local $Archive::Extract::WARN = 0; + Archive::Extract->new( archive => $File::Find::name ) + } or return; + + ### it's a type A::E recognize, so we can add it + $ae->type or return; + + ### neither $_ nor $File::Find::name have the chunk of the path in + ### it starting $path -- it's either only the filename, or the full + ### path, so we have to strip it ourselves + ### make sure to remove the leading slash as well. + my $copy = $File::Find::name; + my $re = quotemeta($path); + $copy =~ s|^$path[\\/]?||i; + + push @files, $copy; + + }, $path ); + + ### does the dir exist? if not, create it. + { my $dir = dirname( $to ); + unless( IS_DIR->( $dir ) ) { + $self->_mkdir( dir => $dir ) or return + } + } + + ### create the index file + my $fh = OPEN_FILE->( $to => '>' ) or return; + + print $fh "$_\n" for @files; + close $fh; + + msg(loc("Successfully written index file to '%1'", $to), $verbose); + + return $to; +} + + +=head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] ) + +Creates entries in the module tree based upon the files as returned +by C<__list_custom_module_sources>. + +Returns true on success, false on failure. + +=cut + +### use $auth_obj as a persistant version, so we don't have to recreate +### modules all the time +{ my $auth_obj; + + sub __create_custom_module_entries { + my $self = shift; + my $conf = $self->configure_object; + my %hash = @_; + + my $verbose; + my $tmpl = { + verbose => { default => $conf->get_conf('verbose'), store => \$verbose }, + }; + + check( $tmpl, \%hash ) or return undef; + + my %files = $self->__list_custom_module_sources; + + while( my($file,$name) = each %files ) { + + msg(loc("Adding packages from custom source '%1'", $name), $verbose); + + my $fh = OPEN_FILE->( $file ) or next; + + while( <$fh> ) { + chomp; + next if /^#/; + next unless /\S+/; + + ### join on / -- it's a URI after all! + my $parse = join '/', $name, $_; + + ### try to make a module object out of it + my $mod = $self->parse_module( module => $parse ) or ( + error(loc("Could not parse '%1'", $_)), + next + ); + + ### mark this object with a custom author + $auth_obj ||= do { + my $id = CUSTOM_AUTHOR_ID; + + ### if the object is being created for the first time, + ### make sure there's an entry in the author tree as + ### well, so we can search on the CPAN ID + $self->author_tree->{ $id } = + CPANPLUS::Module::Author::Fake->new( cpanid => $id ); + }; + + $mod->author( $auth_obj ); + + ### and now add it to the modlue tree -- this MAY + ### override things of course + if( $self->module_tree( $mod->module ) ) { + msg(loc("About to overwrite module tree entry for '%1' with '%2'", + $mod->module, $mod->package), $verbose); + } + + ### mark where it came from + $mod->description( loc("Custom source from '%1'",$name) ); + + ### store it in the module tree + $self->module_tree->{ $mod->module } = $mod; + } + } + + return 1; + } +} + + # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 diff --git a/lib/CPANPLUS/Internals/Utils.pm b/lib/CPANPLUS/Internals/Utils.pm index 6251608..3f38aaa 100644 --- a/lib/CPANPLUS/Internals/Utils.pm +++ b/lib/CPANPLUS/Internals/Utils.pm @@ -344,14 +344,15 @@ sub _host_to_uri { my($scheme, $host, $path); my $tmpl = { - scheme => { required => 1, store => \$scheme }, - host => { default => '', store => \$host }, - path => { default => '', store => \$path }, + scheme => { required => 1, store => \$scheme }, + host => { default => 'localhost', store => \$host }, + path => { default => '', store => \$path }, }; check( $tmpl, \%hash ) or return; - $host ||= 'localhost'; + ### it's an URI, so unixify the path + $path = File::Spec::Unix->catdir( File::Spec->splitdir( $path ) ); return "$scheme://" . File::Spec::Unix->catdir( $host, $path ); } @@ -391,8 +392,11 @@ sub _home_dir { =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. +Returns a path that's safe to us on Win32 and VMS. + +Only cleans up the path on Win32 if the path exists. + +On VMS, it encodes dots to _ using C =cut @@ -408,15 +412,57 @@ sub _safe_path { check( $tmpl, \%hash ) or return; - ### only need to fix it up if there's spaces in the path - return $path unless $path =~ /\s+/; + if( ON_WIN32 ) { + ### 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'; - ### 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; - + ### clean up paths if we are on win32 + return Win32::GetShortPathName( $path ) || $path; + + } elsif ( ON_VMS ) { + ### XXX According to John Malmberg, there's an VMS issue: + ### catdir on VMS can not currently deal with directory components + ### with dots in them. + ### Fixing this is a a three step procedure, which will work for + ### VMS in its traditional ODS-2 mode, and it will also work if + ### VMS is in the ODS-5 mode that is being implemented. + + ### 1. Make sure that the value to be converted, $path is + ### in UNIX directory syntax by appending a '/' to it. + $path .= '/' unless $path =~ m|/$|; + + ### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to + ### underscores if needed. The trailing '/' is needed as so that + ### C knows that it should use directory translation instead of + ### filename translation, as filename translation leaves one dot. + $path = VMS::Filespec::vmsify( $path ); + + ### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify( + ### $path . '/') to remove the directory delimiters. + + ### From John Malmberg: + ### File::Spec->catdir will put the path back together. + ### The '/' trick only works if the string is a directory name + ### with UNIX style directory delimiters or no directory delimiters. + ### It is to force vmsify to treat the input specification as UNIX. + ### + ### There is a VMS::Filespec::unixpath() to do the appending of the '/' + ### to the specification, which will do a VMS::Filespec::vmsify() + ### if needed. + ### However it is not a good idea to call vmsify() on a pathname + ### returned by unixify(), and it is not a good idea to call unixify() + ### on a pathname returned by vmsify(). Because of the nature of the + ### conversion, not all file specifications can make the round trip. + ### + ### I think that directory specifications can safely make the round + ### trip, but not ones containing filenames. + $path = File::Spec->catdir( File::Spec->splitdir( $path ) ) + } + + return $path; } @@ -526,6 +572,72 @@ sub _split_package_string { } } +{ my %escapes = map { + chr($_) => sprintf("%%%02X", $_) + } 0 .. 255; + + sub _uri_encode { + my $self = shift; + my %hash = @_; + + my $str; + my $tmpl = { + uri => { store => \$str, required => 1 } + }; + + check( $tmpl, \%hash ) or return; + + ### XXX taken straight from URI::Encode + ### Default unsafe characters. RFC 2732 ^(uric - reserved) + $str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g; + + return $str; + } + + + sub _uri_decode { + my $self = shift; + my %hash = @_; + + my $str; + my $tmpl = { + uri => { store => \$str, required => 1 } + }; + + check( $tmpl, \%hash ) or return; + + ### XXX use unencode routine in utils? + $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + + return $str; + } +} + +sub _update_timestamp { + my $self = shift; + my %hash = @_; + + my $file; + my $tmpl = { + file => { required => 1, store => \$file, allow => FILE_EXISTS } + }; + + check( $tmpl, \%hash ) or return; + + ### `touch` the file, so windoze knows it's new -jmb + ### works on *nix too, good fix -Kane + ### make sure it is writable first, otherwise the `touch` will fail + + my $now = time; + unless( chmod( 0644, $file) && utime ($now, $now, $file) ) { + error( loc("Couldn't touch %1", $file) ); + return; + } + + return 1; +} + + 1; # Local variables: diff --git a/lib/CPANPLUS/Selfupdate.pm b/lib/CPANPLUS/Selfupdate.pm index adcb575..bea8e12 100644 --- a/lib/CPANPLUS/Selfupdate.pm +++ b/lib/CPANPLUS/Selfupdate.pm @@ -46,7 +46,8 @@ CPANPLUS::Selfupdate 'Locale::Maketext::Simple' => '0.01', 'Log::Message' => '0.01', 'Module::Load' => '0.10', - 'Module::Load::Conditional' => '0.16', # Better parsing: #23995 + 'Module::Load::Conditional' => '0.18', # Better parsing: #23995, + # uses version.pm for <=> 'version' => '0.70', # needed for M::L::C # addresses #24630 and # #24675 @@ -81,12 +82,9 @@ CPANPLUS::Selfupdate ], cpantest => [ { - LWP => '0.0', - 'LWP::UserAgent' => '0.0', - 'HTTP::Request' => '0.0', - URI => '0.0', - YAML => '0.0', - 'Test::Reporter' => 1.27, + 'YAML::Tiny' => '0.0', + 'File::Fetch' => '0.08', + 'Test::Reporter' => '1.34', }, sub { my $cb = shift; diff --git a/lib/CPANPLUS/Shell.pm b/lib/CPANPLUS/Shell.pm index 13cb051..b56adeb 100644 --- a/lib/CPANPLUS/Shell.pm +++ b/lib/CPANPLUS/Shell.pm @@ -49,19 +49,24 @@ 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; - + : do { ### XXX this should offer to reconfigure + ### CPANPLUS, somehow. --rs + ### XXX load Configure only if we really have to + ### as that means any $Conf passed later on will + ### be ignored in favour of the one that was + ### retrieved via ->new --kane + my $conf = CPANPLUS::Configure->new() or + die loc("No configuration available -- aborting") . $/; + $conf->get_conf('shell') || $DEFAULT; + }; + ### load the shell, fall back to the default if required ### and die if even that doesn't work EVAL: { @@ -185,11 +190,13 @@ sub _show_banner { $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->__print( + loc("%1 -- CPAN exploration and module installation (v%2)", $self->which, $self->which->VERSION()), "\n", loc("*** Please report bugs to ."), "\n", loc("*** Using CPANPLUS::Backend v%1. %2", - $cpan->VERSION, $rl_avail), "\n\n"; + $cpan->VERSION, $rl_avail), "\n\n" + ); } ### checks whether the Term::ReadLine is broken and needs to fallback to Stub @@ -279,6 +286,24 @@ sub _pager_close { } } +### Custom print routines, mainly to be able to catch output +### in test cases, or redirect it if need be +{ sub __print { + my $self = shift; + print @_; + } + + sub __printf { + my $self = shift; + my $fmt = shift; + + ### MUST specify $fmt as a seperate param, and not as part + ### of @_, as it will then miss the $fmt and return the + ### number of elements in the list... =/ --kane + $self->__print( sprintf( $fmt, @_ ) ); + } +} + 1; =pod diff --git a/lib/CPANPLUS/Shell/Default.pm b/lib/CPANPLUS/Shell/Default.pm index 08fb19c..2a2e375 100644 --- a/lib/CPANPLUS/Shell/Default.pm +++ b/lib/CPANPLUS/Shell/Default.pm @@ -26,7 +26,7 @@ local $Data::Dumper::Indent = 1; # for dumpering from ! BEGIN { use vars qw[ $VERSION @ISA ]; @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ]; - $VERSION = "0.82"; + $VERSION = "0.83_02"; } load CPANPLUS::Shell; @@ -159,7 +159,7 @@ can start it via the C binary, or as detailed in the L. sub new { my $class = shift; - my $cb = new CPANPLUS::Backend; + my $cb = CPANPLUS::Backend->new( @_ ); my $self = $class->SUPER::_init( brand => $Brand, term => Term::ReadLine->new( $Brand ), @@ -178,7 +178,7 @@ sub new { if( -e $rc_file && -r _ ) { - $rc = _read_configuration_from_rc( $rc_file ); + $rc = $self->_read_configuration_from_rc( $rc_file ); } ### register install callback ### @@ -207,6 +207,8 @@ sub new { code => \&__ask_about_test_failure, ); + ### load all the plugins + $self->_plugins_init; return $self; } @@ -217,9 +219,9 @@ sub shell { my $conf = $self->backend->configure_object; $self->_show_banner; - print "*** Type 'p' now to show start up log\n"; # XXX add to banner? + $self->__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->_input_loop && $self->__print( "\n" ); $self->_quit; } @@ -238,7 +240,7 @@ sub _input_loop { $SIG{$sig} = $entry->{handler} if exists($entry->{handler}); } - print "\n"; + $self->__print( "\n" ); last if $self->dispatch_on_input( input => $input ); ### flush the lib cache ### @@ -292,9 +294,9 @@ sub dispatch_on_input { ### 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". + $self->__print( loc("Could not understand command: %1\n". "Possibly missing command before argument(s)?\n", - $org_input); + $org_input) ); return; } @@ -330,18 +332,19 @@ sub dispatch_on_input { if( $key eq 'z' or ($key eq 's' and $input =~ /^\s*edit/) ) { - print "\n", + $self->__print( "\n", loc( "Command '%1' not supported over remote connection", join ' ', $key, $input - ), "\n\n"; + ), "\n\n" ); } else { my($status,$buff) = $self->__send_remote_command($org_input); - print "\n", loc("Command failed!"), "\n\n" unless $status; + $self->__print( "\n", loc("Command failed!"), "\n\n" ) + unless $status; $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount; - print $buff; + $self->__print( $buff ); $self->_pager_close; } @@ -349,7 +352,7 @@ sub dispatch_on_input { } else { unless( $self->can($method) ) { - print loc("Unknown command '%1'. Usage:", $key), "\n"; + $self->__print(loc("Unknown command '%1'. Usage:", $key), "\n"); $self->_help; } else { @@ -391,20 +394,20 @@ sub _select_modules { ### it's a cache look up ### if( $mod =~ /^\d+/ and $mod > 0 ) { unless( scalar @$cache ) { - print loc("No search was done yet!"), "\n"; + $self->__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"; + $self->__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"; + $self->__print( loc("No such module: %1", $mod), "\n" ); } else { push @rv, $obj; @@ -413,7 +416,7 @@ sub _select_modules { } unless( scalar @rv ) { - print loc("No modules found to operate on!\n"); + $self->__print( loc("No modules found to operate on!\n") ); return; } else { return @rv; @@ -454,19 +457,23 @@ sub __display_results { ### 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(); + $self->__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(); + $self->__printf( + $self->format, + $i, + $mod->module, + $self->_format_version( $mod->version ), + $mod->author->cpanid + ); } $i++; } @@ -474,7 +481,7 @@ sub __display_results { $self->_pager_close; } else { - print loc("No results to display"), "\n"; + $self->__print( loc("No results to display"), "\n" ); } } @@ -485,7 +492,7 @@ sub _quit { $self->dispatch_on_input( input => $rc->{'logout'} ) if defined $rc->{'logout'}; - print loc("Exiting CPANPLUS shell"), "\n"; + $self->__print( loc("Exiting CPANPLUS shell"), "\n" ); } ########################### @@ -556,10 +563,10 @@ loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ), $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->__print( "Detailed help for the command '$input' is " . + "not available.\n\n" ) if length $input; + $self->__print( map {"$_\n"} @help ); + $self->__print( $/ ); $self->_pager_close; } } @@ -584,7 +591,7 @@ sub _bang { local $Data::Dumper::Indent = 1; # for dumpering from ! eval $input; error( $@ ) if $@; - print "\n"; + $self->__print( "\n" ); return; } @@ -685,7 +692,7 @@ sub _readme { $self->_pager_open; for my $mod ( @$mods ) { - print $mod->readme( %$opts ); + $self->__print( $mod->readme( %$opts ) ); } $self->_pager_close; @@ -713,11 +720,13 @@ sub _fetch { for my $mod (@$mods) { my $where = $mod->fetch( %$opts ); - print $where + $self->__print( + $where ? loc("Successfully fetched '%1' to '%2'", $mod->module, $where ) - : loc("Failed to fetch '%1'", $mod->module); - print "\n"; + : loc("Failed to fetch '%1'", $mod->module) + ); + $self->__print( "\n" ); } $self->_pager_close; @@ -731,8 +740,10 @@ sub _shell { 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"; + $self->__print( + loc("Your config does not specify a subshell!"), "\n", + loc("Perhaps you need to re-run your setup?"), "\n" + ); return; } @@ -757,8 +768,10 @@ sub _shell { #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt; if( system($shell) and $! ) { - print loc("Error executing your subshell '%1': %2", - $shell, $!),"\n"; + $self->__print( + loc("Error executing your subshell '%1': %2", + $shell, $!),"\n" + ); next; } } @@ -817,8 +830,9 @@ sub _reload_indices { ### 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"; + $self->__print( + "\nFailure may be due to corrupt source files\n" . + "Try this:\n\tx --update_source\n\n" ); } return $rv; @@ -845,7 +859,7 @@ sub _install { } unless( scalar @$mods ) { - print loc("Nothing done\n"); + $self->__print( loc("Nothing done\n") ); return; } @@ -856,7 +870,7 @@ sub _install { my $status = {}; ### first loop over the mods to install them ### for my $mod (@$mods) { - print $prompt, $mod->module, " (".$mod->version.")", "\n"; + $self->__print( $prompt, $mod->module, " (".$mod->version.")", "\n" ); my $log_length = length CPANPLUS::Error->stack_as_string; @@ -887,7 +901,9 @@ sub _install { print $fh $stack; close $fh; - print loc("*** Install log written to:\n %1\n\n", $file); + $self->__print( + loc("*** Install log written to:\n %1\n\n", $file) + ); } else { warn "Could not open '$file': $!\n"; next; @@ -900,26 +916,36 @@ sub _install { for my $mod (@$mods) { # if( $mod->status->installed ) { if( $status->{$mod} ) { - print loc("Module '%1' %tense(%2,past) successfully\n", - $mod->module, $action) + $self->__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); + $self->__print( + loc("Error %tense(%1,present) '%2'\n", $action, $mod->module) + ); } } if( !$flag ) { - print loc("No errors %tense(%1,present) all modules", $action), "\n"; + $self->__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; + $self->__print( + loc("Problem %tense(%1,present) one or more modules", $action) + ); + $self->__print( "\n" ); + + $self->__print( + loc("*** You can view the complete error buffer by pressing ". + "'%1' ***\n", 'p') + ) unless $conf->get_conf('verbose') || $self->noninteractive; } - print "\n"; + $self->__print( "\n" ); return !$flag; } @@ -929,15 +955,16 @@ sub __ask_about_install { 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". + $Shell->__print( "\n" ); + $Shell->__print( loc("Module '%1' requires '%2' to be installed", + $mod->module, $prereq->module ) ); + $Shell->__print( "\n\n" ); + $Shell->__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"; + 's conf prereqs 1; s save' ) ); + $Shell->__print("\n\n"); my $bool = $term->ask_yn( prompt => loc("Should I install this module?"), @@ -953,10 +980,11 @@ sub __ask_about_send_test_report { 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"; + $Shell->__print( "\n" ); + $Shell->__print( + loc("Test report prepared for module '%1'.\n Would you like to ". + "send it? (You can edit it if you like)", $mod->module ) ); + $Shell->__print( "\n\n" ); my $bool = $term->ask_yn( prompt => loc("Would you like to send the test report?"), default => 'n' @@ -971,10 +999,11 @@ sub __ask_about_edit_test_report { 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"; + $Shell->__print( "\n" ); + $Shell->__print( + loc("Test report prepared for module '%1'. You can edit this ". + "report if you would like", $mod->module ) ); + $Shell->__print("\n\n"); my $bool = $term->ask_yn( prompt => loc("Would you like to edit the test report?"), default => 'y' @@ -988,10 +1017,11 @@ sub __ask_about_test_failure { my $captured = shift || ''; my $term = $Shell->term; - print "\n"; - print loc( "The tests for '%1' failed. Would you like me to proceed ". - "anyway or should we abort?", $mod->module ); - print "\n\n"; + $Shell->__print( "\n" ); + $Shell->__print( + loc( "The tests for '%1' failed. Would you like me to proceed ". + "anyway or should we abort?", $mod->module ) ); + $Shell->__print( "\n\n" ); my $bool = $term->ask_yn( prompt => loc("Proceed anyway?"), @@ -1030,26 +1060,29 @@ sub _details { 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"; + $self->__print( + loc("No details for %1 - it might be outdated.", + $mod->module), "\n" ); next; } else { - print loc( "Details for '%1'\n", $mod->module ); + $self->__print( loc( "Details for '%1'\n", $mod->module ) ); for my $item ( sort keys %$href ) { - printf $format, $item, $href->{$item}; + $self->__printf( $format, $item, $href->{$item} ); } my $showed; for my $item ( @list ) { - printf $format, ($showed ? '' : 'Contains:'), $item->module; + $self->__printf( + $format, ($showed ? '' : 'Contains:'), $item->module + ); $showed++; } - print "\n"; + $self->__print( "\n" ); } } $self->_pager_close; - print "\n"; + $self->__print( "\n" ); return 1; } @@ -1081,12 +1114,12 @@ sub _print { $self->_pager_open if !$file; - print CPANPLUS::Error->stack_as_string; + $self->__print( CPANPLUS::Error->stack_as_string ); $self->_pager_close; select $old if $old; - print "\n"; + $self->__print( "\n" ); return 1; } @@ -1155,10 +1188,12 @@ sub _set_conf { my $rv = $cb->configure_object->save( $where => $dir ); - print $rv + $self->__print( + $rv ? loc("Configuration successfully saved to %1\n (%2)\n", $where, $rv) - : loc("Failed to save configuration\n" ); + : loc("Failed to save configuration\n" ) + ); return $rv; } elsif ( $type eq 'edit' ) { @@ -1188,14 +1223,15 @@ sub _set_conf { } elsif ( $type eq 'mirrors' ) { - print loc("Readonly list of mirrors (in order of preference):\n\n" ); + $self->__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"; + $self->__print( "\t[$i] $uri\n" ); } } elsif ( $type eq 'selfupdate' ) { @@ -1203,13 +1239,15 @@ sub _set_conf { $cb->selfupdate_object->list_categories; unless( $valid{$key} ) { - print loc( "To update your current CPANPLUS installation, ". + $self->__print( + loc( "To update your current CPANPLUS installation, ". "choose one of the these options:\n%1", ( join $/, map { sprintf "\ts selfupdate %-17s " . "[--latest=0] [--dryrun]", $_ } sort keys %valid ) - ); + ) + ); } else { my %update_args = ( update => $key, @@ -1221,28 +1259,32 @@ sub _set_conf { my %list = $cb->selfupdate_object ->list_modules_to_update( %update_args ); - print loc( "The following updates will take place:" ), $/.$/; + $self->__print(loc("The following updates will take place:"),$/.$/); for my $feature ( sort keys %list ) { my $aref = $list{$feature}; ### is it a 'feature' or a built in? - print $valid{$feature} - ? " " . ucfirst($feature) . ":\n" - : " Modules for '$feature' support:\n"; + $self->__print( + $valid{$feature} + ? " " . ucfirst($feature) . ":\n" + : " Modules for '$feature' support:\n" + ); ### show what modules would be installed - print scalar @$aref - ? map { sprintf " %-42s %-6s -> %-6s \n", - $_->name, $_->installed_version, $_->version - } @$aref - : " No upgrades required\n"; - print $/; + $self->__print( + scalar @$aref + ? map { sprintf " %-42s %-6s -> %-6s \n", + $_->name, $_->installed_version, $_->version + } @$aref + : " No upgrades required\n" + ); + $self->__print( $/ ); } unless( $opts->{'dryrun'} ) { - print loc( "Updating your CPANPLUS installation\n" ); + $self->__print( loc("Updating your CPANPLUS installation\n") ); $cb->selfupdate_object->selfupdate( %update_args ); } } @@ -1268,30 +1310,33 @@ sub _set_conf { ($val) = ref($val) ? (Data::Dumper::Dumper($val) =~ /= (.*);$/) : "'$val'"; - printf " $format\n", $name, $val; + + $self->__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'); + $self->__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'); + and $self->__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 $/, + $self->__print( loc("Unknown type '%1'",$type || 'EMPTY' ) ); + $self->__print( $/ ); + $self->__print( loc("Try one of the following:") ); + $self->__print( $/, join $/, map { sprintf "\t%-11s %s", $_, $types{$_} } - sort keys %types; + sort keys %types ); } } - print "\n"; + $self->__print( "\n" ); return 1; } @@ -1339,12 +1384,14 @@ sub _uptodate { 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(); + $self->__printf( + $format, + $i, + $self->_format_version($mod->installed_version) || 'Unparsable', + $self->_format_version( $mod->version ), + $mod->module, + $mod->author->cpanid + ); $i++; } $self->_pager_close; @@ -1373,10 +1420,12 @@ sub _autobundle { my $where = $cb->autobundle( %$opts ); - print $where + $self->__print( + $where ? loc("Wrote autobundle to '%1'", $where) - : loc("Could not create autobundle" ); - print "\n"; + : loc("Could not create autobundle" ) + ); + $self->__print( "\n" ); return $where ? 1 : 0; } @@ -1404,14 +1453,14 @@ sub _uninstall { unless( $force ) { my $list = join "\n", map { ' ' . $_->module } @$mods; - print loc(" + $self->__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); +", $list) ); return unless $term->ask_yn( prompt => loc("Are you sure you want to continue?"), @@ -1421,7 +1470,7 @@ should use the same package manager to uninstall them ### first loop over all the modules to uninstall them ### for my $mod (@$mods) { - print loc("Uninstalling '%1'", $mod->module), "\n"; + $self->__print( loc("Uninstalling '%1'", $mod->module), "\n" ); $mod->uninstall( %$opts ); } @@ -1430,23 +1479,29 @@ should use the same package manager to uninstall them ### 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 ) + $self->__print( + loc("Module '%1' %tense(uninstall,past) successfully\n", + $mod->module ) ); } else { $flag++; - print loc("Error %tense(uninstall,present) '%1'\n", $mod->module); + $self->__print( + loc("Error %tense(uninstall,present) '%1'\n", $mod->module) ); } } if( !$flag ) { - print loc("All modules %tense(uninstall,past) successfully"), "\n"; + $self->__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'); + $self->__print( + loc("Problem %tense(uninstalling,present) one or more modules" ), + "\n" ); + + $self->__print( + loc("*** You can view the complete error buffer by pressing '%1'". + "***\n", 'p') ) unless $conf->get_conf('verbose'); } - print "\n"; + $self->__print( "\n" ); return !$flag; } @@ -1491,17 +1546,22 @@ sub _reports { 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'} ? '(*)' : ''); + $self->__print( + "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n" + ) unless $seen{ $href->{'dist'} }++; + + $self->__printf( + $format, + $href->{'grade'}, + $href->{'platform'}, + ($href->{'details'} ? '(*)' : '') + ); $url ||= $href->{'details'}; } - print "\n==> $url\n" if $url; - print "\n"; + $self->__print( "\n==> $url\n" ) if $url; + $self->__print( "\n" ); } $self->_pager_close; @@ -1520,46 +1580,52 @@ sub _reports { 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 $@; + my $init_done; + sub _plugins_init { + ### only initialize once + return if $init_done++; + + ### find all plugins first + if( check_install( module => 'Module::Pluggable', version => '2.4') ) { + require Module::Pluggable; - ### 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; - } + my $only_re = __PACKAGE__ . '::Plugins::\w+$'; - ### register name, package and function - $Dispatch{$name} = [ $p, $func ]; + 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; @@ -1599,12 +1665,14 @@ sub _reports { } ### plugin commands -{ my $help_format = " /%-20s # %s\n"; +{ my $help_format = " /%-21s # %s\n"; sub _list_plugins { - print loc("Available plugins:\n"); - print loc(" List usage by using: /? PLUGIN_NAME\n" ); - print $/; + my $self = shift; + + $self->__print( loc("Available plugins:\n") ); + $self->__print( loc(" List usage by using: /? PLUGIN_NAME\n" ) ); + $self->__print( $/ ); my %table = __PACKAGE__->plugin_table; for my $name( sort keys %table ) { @@ -1615,15 +1683,16 @@ sub _reports { ? "Standard Plugin" : do { $pkg =~ s/^$this/../; "Provided by: $pkg" }; - printf $help_format, $name, $who; + $self->__printf( $help_format, $name, $who ); } - print $/.$/; + $self->__print( $/.$/ ); - print " Write your own plugins? Read the documentation of:\n" . - " CPANPLUS::Shell::Default::Plugins::HOWTO\n"; + $self->__print( + " Write your own plugins? Read the documentation of:\n" . + " CPANPLUS::Shell::Default::Plugins::HOWTO\n" ); - print $/; + $self->__print( $/ ); } sub _list_plugins_help { @@ -1636,12 +1705,12 @@ sub _reports { } sub _plugins_usage { - my $pkg = shift; + my $self = shift; my $shell = shift; my $cb = shift; my $cmd = shift; my $input = shift; - my %table = __PACKAGE__->plugin_table; + my %table = $self->plugin_table; my @list = length $input ? split /\s+/, $input : sort keys %table; @@ -1654,17 +1723,17 @@ sub _reports { my $func = $table{$name}->[1] . '_help'; if ( my $sub = $pkg->can( $func ) ) { - eval { print $sub->() }; + eval { $self->__print( $sub->() ) }; error( $@ ) if $@; } else { - print " No usage for '$name' -- try perldoc $pkg"; + $self->__print(" No usage for '$name' -- try perldoc $pkg"); } - print $/; + $self->__print( $/ ); } - print $/.$/; + $self->__print( $/.$/ ); } sub _plugins_usage_help { @@ -1704,6 +1773,7 @@ sub __send_remote_command { sub _read_configuration_from_rc { + my $self = shift; my $rc_file = shift; my $href; @@ -1712,8 +1782,9 @@ sub _read_configuration_from_rc { eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) }; - print loc( "Unable to read in config file '%1': %2", - $rc_file, $@ ) if $@; + $self->__print( + loc( "Unable to read in config file '%1': %2", $rc_file, $@ ) + ) if $@; } return $href || {}; @@ -1734,12 +1805,15 @@ sub _read_configuration_from_rc { 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' ), - loc( "You can run an interactive setup using '%1'", 's reconfigure' ), + loc( "You can run an interactive setup using '%1'", 's reconfigure' ), + loc( "You can add custom sources to your index. See '%1' for details", + '/cs --help' ), ); sub _show_random_tip { my $self = shift; - print $/, "Did you know...\n ", $tips[ int rand scalar @tips ], $/; + $self->__print( $/, "Did you know...\n ", + $tips[ int rand scalar @tips ], $/ ); return 1; } } diff --git a/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm b/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm new file mode 100644 index 0000000..e055fbf --- /dev/null +++ b/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm @@ -0,0 +1,197 @@ +package CPANPLUS::Shell::Default::Plugins::CustomSource; + +use strict; +use CPANPLUS::Error qw[error msg]; +use CPANPLUS::Internals::Constants; + +use Data::Dumper; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +=head1 NAME + +CPANPLUS::Shell::Default::Plugins::CustomSource + +=head1 SYNOPSIS + + ### elaborate help text + CPAN Terminal> /? cs + + ### add a new custom source + CPAN Terminal> /cs --add file:///path/to/releases + + ### list all your custom sources by + CPAN Terminal> /cs --list + + ### display the contents of a custom source by URI or ID + CPAN Terminal> /cs --contents file:///path/to/releases + CPAN Terminal> /cs --contents 1 + + ### Update a custom source by URI or ID + CPAN Terminal> /cs --update file:///path/to/releases + CPAN Terminal> /cs --update 1 + + ### Remove a custom source by URI or ID + CPAN Terminal> /cs --remove file:///path/to/releases + CPAN Terminal> /cs --remove 1 + + ### Write an index file for a custom source, to share + ### with 3rd parties or remote users + CPAN Terminal> /cs --write file:///path/to/releases + + ### Make sure to save your sources when adding/removing + ### sources, so your changes are reflected in the cache: + CPAN Terminal> x + +=head1 DESCRIPTION + +This is a C plugin that can add +custom sources to your CPANPLUS installation. This is a +wrapper around the C code as outlined +in L. + +This allows you to extend your index of available modules +beyond what's available on C with your own local +distributions, or ones offered by third parties. + +=cut + + +sub plugins { + return ( cs => 'custom_source' ) +} + +my $Cb; +my $Shell; +my @Index = (); + +sub _uri_from_cache { + my $self = shift; + my $input = shift or return; + + ### you gave us a search number + my $uri = $input =~ /^\d+$/ + ? $Index[ $input - 1 ] # remember, off by 1! + : $input; + + my %files = reverse $Cb->list_custom_sources; + + ### it's an URI we know + if( my $local = $files{ $uri } ) { + return wantarray + ? ($uri, $local) + : $uri; + } + + ### couldn't resolve the input + error(loc("Unknown URI/index: '%1'", $input)); + return; +} + +sub _list_custom_sources { + my $class = shift; + + my %files = $Cb->list_custom_sources; + + $Shell->__print( loc("Your remote sources:"), $/ ) if keys %files; + + my $i = 0; + while(my($local,$remote) = each %files) { + $Shell->__printf( " [%2d] %s\n", ++$i, $remote ); + + ### remember, off by 1! + push @Index, $remote; + } + + $Shell->__print( $/ ); +} + +sub _list_contents { + my $class = shift; + my $input = shift; + + my ($uri,$local) = $class->_uri_from_cache( $input ); + unless( $uri ) { + error(loc("--contents needs URI parameter")); + return; + } + + my $fh = OPEN_FILE->( $local ) or return; + + $Shell->__printf( " %s", $_ ) for sort <$fh>; + $Shell->__print( $/ ); +} + +sub custom_source { + my $class = shift; + my $shell = shift; $Shell = $shell; # available to all methods now + my $cb = shift; $Cb = $cb; # available to all methods now + my $cmd = shift; + my $input = shift || ''; + my $opts = shift || {}; + + ### show a list + if( $opts->{'list'} ) { + $class->_list_custom_sources; + + } elsif ( $opts->{'contents'} ) { + $class->_list_contents( $input ); + + } elsif ( $opts->{'add'} ) { + unless( $input ) { + error(loc("--add needs URI parameter")); + return; + } + + $cb->add_custom_source( uri => $input ) + and $shell->__print(loc("Added remote source '%1'", $input), $/); + + $Shell->__print($/, loc("Remote source contains:"), $/, $/); + $class->_list_contents( $input ); + + } elsif ( $opts->{'remove'} ) { + my($uri,$local) = $class->_uri_from_cache( $input ); + unless( $uri ) { + error(loc("--remove needs URI parameter")); + return; + } + + 1 while unlink $local; + + $shell->__print( loc("Removed remote source '%1'", $uri), $/ ); + + } elsif ( $opts->{'update'} ) { + ### did we get input? if so, it's a remote part + my $uri = $class->_uri_from_cache( $input ); + + $cb->update_custom_source( $uri ? ( remote => $uri ) : () ) + and do { $shell->__print( loc("Updated remote sources"), $/ ) }; + + } elsif ( $opts->{'write'} ) { + $cb->write_custom_source_index( path => $input ) and + $shell->__print( loc("Wrote remote source index for '%1'", $input), $/); + + } else { + error(loc("Unrecognized command, see '%1' for help", '/? cs')); + } + + return; +} + +sub custom_source_help { + return loc( + $/ . + ' # Plugin to manage custom sources from the default shell' . $/ . + " # See the 'CUSTOM MODULE SOURCES' section in the " . $/ . + ' # CPANPLUS::Backend documentation for details.' . $/ . + ' /cs --list # list available sources' . $/ . + ' /cs --add URI # add source' . $/ . + ' /cs --remove URI | INDEX # remove source' . $/ . + ' /cs --contents URI | INDEX # show packages from source'. $/ . + ' /cs --update [URI | INDEX] # update source index' . $/ . + ' /cs --write PATH # write source index' . $/ + ); + +} + +1; + diff --git a/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t b/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t index 5634b1a..2b3ad5a 100644 --- a/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t +++ b/lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t @@ -8,7 +8,7 @@ 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 Test::More tests => 40; use Cwd; use Data::Dumper; @@ -37,7 +37,8 @@ rmdir $Dir if -d $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'" ); + like( File::Spec->rel2abs(cwd()), qr/$Cwd/i, + " Cwd() is '$Cwd'" ); } ### test _move ### @@ -118,8 +119,19 @@ rmdir $Dir if -d $Dir; ok( !-e $File, " File removed" ); } - +### uri encode/decode tests +{ my $org = 'file://foo/bar'; + + my $enc = $Class->_uri_encode( uri => $org ); + + ok( $enc, "String '$org' encoded" ); + like( $enc, qr/%/, " Contents as expected" ); + + my $dec = $Class->_uri_decode( uri => $enc ); + ok( $dec, "String '$enc' decoded" ); + is( $dec, $org, " Decoded properly" ); +} diff --git a/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t b/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t index b1d5c04..d2ce5cd 100644 --- a/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t +++ b/lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t @@ -7,13 +7,18 @@ BEGIN { use strict; use CPANPLUS::Backend; +use CPANPLUS::Internals::Constants; use Test::More 'no_plan'; use Data::Dumper; +use File::Basename qw[dirname]; my $conf = gimme_conf(); +my $cb = CPANPLUS::Backend->new( $conf ); + +### XXX temp +# $conf->set_conf( verbose => 1 ); -my $cb = CPANPLUS::Backend->new( $conf ); isa_ok($cb, "CPANPLUS::Internals" ); my $mt = $cb->_module_tree; @@ -28,14 +33,151 @@ for my $name (qw[auth mod dslip] ) { ok( (-e $file && -f _ && -s _), "$file exists" ); } -ok( scalar keys %$at, "Authortree loaded successfully" ); -ok( scalar keys %$mt, "Moduletree loaded successfully" ); +ok( scalar keys %$at, "Authortree loaded successfully" ); +ok( scalar keys %$mt, "Moduletree loaded successfully" ); + +### test lookups +{ my $auth = $at->{'EUNOXS'}; + my $mod = $mt->{$modname}; + + isa_ok( $auth, 'CPANPLUS::Module::Author' ); + isa_ok( $mod, 'CPANPLUS::Module' ); +} + +### check custom sources +### XXX whitebox test +{ ### first, find a file to serve as a source + my $mod = $mt->{$modname}; + my $package = File::Spec->rel2abs( + File::Spec->catfile( + $FindBin::Bin, + TEST_CONF_CPAN_DIR, + $mod->path, + $mod->package, + ) + ); + + ok( $package, "Found file for custom source" ); + ok( -e $package, " File '$package' exists" ); + + ### remote uri + my $uri = $cb->_host_to_uri( + scheme => 'file', + host => '', + path => File::Spec->catfile( dirname($package) ) + ); + + ### local file + my $src_file = $cb->_add_custom_module_source( uri => $uri ); + ok( $src_file, "Sources written to '$src_file'" ); + ok( -e $src_file, " File exists" ); + + ### and write the file + { my $meth = '__write_custom_module_index'; + can_ok( $cb, $meth ); + + my $rv = $cb->$meth( + path => dirname( $package ), + to => $src_file + ); + + ok( $rv, " Sources written" ); + is( $rv, $src_file, " Written to expected file" ); + ok( -e $src_file, " Source file exists" ); + ok( -s $src_file, " File has non-zero size" ); + } + + ### let's see if we can find our custom files + { my $meth = '__list_custom_module_sources'; + can_ok( $cb, $meth ); + + my %files = $cb->$meth; + ok( scalar(keys(%files)), + " Got list of sources" ); + ok( $files{ $src_file }," Found proper entry" ); + } + + ### now we can have it be loaded in + { my $meth = '__create_custom_module_entries'; + can_ok( $cb, $meth ); -my $auth = $at->{'EUNOXS'}; -my $mod = $mt->{$modname}; + ### now add our own sources + ok( $cb->$meth, "Sources file loaded" ); -isa_ok( $auth, 'CPANPLUS::Module::Author' ); -isa_ok( $mod, 'CPANPLUS::Module' ); + my $add_name = TEST_CONF_INST_MODULE; + my $add = $mt->{$add_name}; + ok( $add, " Found added module" ); + + ok( $add->status->_fetch_from, + " Full download path set" ); + is( $add->author->cpanid, CUSTOM_AUTHOR_ID, + " Attributed to custom author" ); + + ### since we replaced an existing module, there should be + ### a message on the stack + like( CPANPLUS::Error->stack_as_string, qr/overwrite module tree/i, + " Addition message recorded" ); + } + + ### test updating custom sources + { my $meth = '__update_custom_module_sources'; + can_ok( $cb, $meth ); + + ### mark what time it is now, sleep 1 second for better measuring + my $now = time; + sleep 1; + + my $ok = $cb->$meth; + + ok( $ok, "Custom sources updated" ); + cmp_ok( [stat $src_file]->[9], '>=', $now, + " Timestamp on sourcefile updated" ); + } + + ### now update it individually + { my $meth = '__update_custom_module_source'; + can_ok( $cb, $meth ); + + ### mark what time it is now, sleep 1 second for better measuring + my $now = time; + sleep 1; + + my $ok = $cb->$meth( remote => $uri ); + + ok( $ok, "Custom source for '$uri' updated" ); + cmp_ok( [stat $src_file]->[9], '>=', $now, + " Timestamp on sourcefile updated" ); + } + + ### now update using the higher level API, see if it's part of the update + { CPANPLUS::Error->flush; + + ### mark what time it is now, sleep 1 second for better measuring + my $now = time; + sleep 1; + + my $ok = $cb->_build_trees( + uptodate => 0, + use_stored => 0, + ); + + ok( $ok, "All sources updated" ); + cmp_ok( [stat $src_file]->[9], '>=', $now, + " Timestamp on sourcefile updated" ); + + like( CPANPLUS::Error->stack_as_string, qr/Updating sources from/, + " Update recorded in the log" ); + } + + ### now remove the index file; + { my $meth = '_remove_custom_module_source'; + can_ok( $cb, $meth ); + + my $file = $cb->$meth( uri => $uri ); + ok( $file, "Index file removed" ); + ok( ! -e $file, " File '$file' no longer on disk" ); + } +} # Local variables: # c-indentation-style: bsd diff --git a/lib/CPANPLUS/t/04_CPANPLUS-Module.t b/lib/CPANPLUS/t/04_CPANPLUS-Module.t index 7415033..54236e4 100644 --- a/lib/CPANPLUS/t/04_CPANPLUS-Module.t +++ b/lib/CPANPLUS/t/04_CPANPLUS-Module.t @@ -47,7 +47,7 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); name => $ModName, comment => undef, package => 'Foo-Bar-0.01.tar.gz', - path => 'authors/id/E/EU/EUNOXS', + path => 'authors/id/EUNOXS', version => '0.01', dslip => 'cdpO ', description => 'CPANPLUS Test Package', @@ -76,7 +76,7 @@ isa_ok( $Auth->parent, 'CPANPLUS::Backend' ); ### convenience methods ### { ok( 1, "Convenience functions" ); - is( $Mod->package_name, 'Foo-Bar', " Package name"); + 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"); diff --git a/lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t b/lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t index 2b09fe2..65bde11 100644 --- a/lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t +++ b/lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t @@ -7,6 +7,7 @@ BEGIN { use strict; use Test::More 'no_plan'; use Cwd; +use Config; use File::Basename; use CPANPLUS::Internals::Constants; @@ -45,9 +46,15 @@ ok( DIR_EXISTS->( dir => cwd() ), "DIR_EXISTS finds dir" ); my $tmpl = { MAKEFILE_PL => 'Makefile.PL', - MAKEFILE => 'Makefile', BUILD_PL => 'Build.PL', BLIB => 'blib', + MAKEFILE => do { + ### On vms, it's a different name. See constants + ### file for details + (ON_VMS and $Config::Config{make} =~ /MM[S|K]/i) + ? 'DESCRIP.MMS' + : 'Makefile' + }, }; while ( my($sub,$res) = each %$tmpl ) { diff --git a/lib/CPANPLUS/t/08_CPANPLUS-Backend.t b/lib/CPANPLUS/t/08_CPANPLUS-Backend.t index 947ea84..f6be5a7 100644 --- a/lib/CPANPLUS/t/08_CPANPLUS-Backend.t +++ b/lib/CPANPLUS/t/08_CPANPLUS-Backend.t @@ -163,9 +163,10 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); flub://floo ] ) { my $obj = $cb->parse_module( module => $guess ); - ok( IS_FAKE_MODOBJ->(mod => $obj), "parse_module success by '$guess'" ); + ok( IS_FAKE_MODOBJ->(mod => $obj), + "parse_module success by '$guess'" ); is( $obj->status->_fetch_from, $guess, - " Fetch from set ok" ); + " Fetch from set ok" ); } } @@ -209,8 +210,7 @@ ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" ); } ### installed tests ### -{ - ok( scalar $cb->installed, "Found list of installed modules" ); +{ ok( scalar($cb->installed), "Found list of installed modules" ); } ### autobudle tests ### diff --git a/lib/CPANPLUS/t/15_CPANPLUS-Shell.t b/lib/CPANPLUS/t/15_CPANPLUS-Shell.t index c1e9fbf..09ab382 100644 --- a/lib/CPANPLUS/t/15_CPANPLUS-Shell.t +++ b/lib/CPANPLUS/t/15_CPANPLUS-Shell.t @@ -1,22 +1,136 @@ +### the shell prints to STDOUT, so capture that here +### and we can check the output ### 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'; +### this lets us capture output from the default shell +{ no warnings 'redefine'; -use CPANPLUS::Internals::Constants; + my $out; + *CPANPLUS::Shell::Default::__print = sub { + my $self = shift; + $out .= "@_"; + }; + sub _out { $out } + sub _reset_out { $out = '' } +} -my $Class = 'CPANPLUS::Shell'; -my $Conf = gimme_conf(); +use strict; +use Test::More 'no_plan'; +use CPANPLUS::Internals::Constants; -$Conf->set_conf( shell => SHELL_DEFAULT ); +my $Conf = gimme_conf(); +my $Class = 'CPANPLUS::Shell'; +my $Default = SHELL_DEFAULT; +my $TestMod = TEST_CONF_MODULE; +my $TestAuth= TEST_CONF_AUTHOR; + ### basic load tests -use_ok( $Class ); +use_ok( $Class, 'Default' ); is( $Class->which, SHELL_DEFAULT, "Default shell loaded" ); +### create an object +my $Shell = $Class->new( $Conf ); +ok( $Shell, " New object created" ); +isa_ok( $Shell, $Default, " Object" ); + +### method tests +{ + ### uri to use for /cs tests + my $cs_path = File::Spec->rel2abs( + File::Spec->catfile( + $FindBin::Bin, + TEST_CONF_CPAN_DIR, + ) + ); + my $cs_uri = $Shell->backend->_host_to_uri( + scheme => 'file', + host => '', + path => $cs_path, + ); + + + ### XXX have to keep the list ordered, as some methods only work as + ### expected *after* others have run + my @map = ( + 'v' => qr/CPANPLUS/, + '! $self->__print($$)' => qr/$$/, + '?' => qr/\[General\]/, + 'h' => qr/\[General\]/, + 's' => qr/Unknown type/, + 's conf' => qr/$Default/, + 's program' => qr/sudo/, + 's mirrors' => do { my $re = TEST_CONF_CPAN_DIR; qr/$re/ }, + 's selfupdate' => qr/selfupdate/, + 'b' => qr/autobundle/, + "a $TestAuth" => qr/$TestAuth/, + "m $TestMod" => qr/$TestMod/, + "w" => qr/$TestMod/, + "r 1" => qr/README/, + "r $TestMod" => qr/README/, + "f $TestMod" => qr/$TestAuth/, + "d $TestMod" => qr/$TestMod/, + ### XXX this one prints to stdout in a subprocess -- skipping this + ### for now due to possible PERL_CORE issues + #"t $TestMod" => qr/$TestMod.*tested successfully/i, + "l $TestMod" => qr/$TestMod/, + '! die $$; p' => qr/$$/, + '/plugins' => qr/Available plugins:/i, + '/? ?' => qr/usage/i, + + ### custom source plugin tests + "/? cs" => qr|/cs|, + "/cs --add $cs_uri" => qr/Added remote source/, + "/cs --list" => do { my $re = quotemeta($cs_uri); qr/$re/ }, + "/cs --contents $cs_uri" => qr/$TestAuth/, + "/cs --update" => qr/Updated remote sources/, + "/cs --update $cs_uri" => qr/Updated remote sources/, + "/cs --write $cs_path" => qr/Wrote remote source index/, + "/cs --remove $cs_uri" => qr/Removed remote source/, + ); + + my $meth = 'dispatch_on_input'; + can_ok( $Shell, $meth ); + + while( my($input,$out_re) = splice(@map, 0, 2) ) { + + ### empty output cache + __PACKAGE__->_reset_out; + CPANPLUS::Error->flush; + + ok( 1, "Testing '$input'" ); + $Shell->$meth( input => $input ); + + my $out = __PACKAGE__->_out; + + ### XXX remove me + #diag( $out ); + + ok( $out, " Output received" ); + like( $out, $out_re, " Output matches '$out_re'" ); + } +} + +__END__ + +#### test seperately, they have side effects +'q' => qr/^$/, # no output! +'s save boxed' => do { my $re = CONFIG_BOXED; qr/$re/ }, +### this doens't write any output +'x --update_source' => qr/module tree/i, +s edit +s reconfigure +'c' => '_reports', +'i' => '_install', +'u' => '_uninstall', +'z' => '_shell', +### might not have any out of date modules... +'o' => '_uptodate', + + diff --git a/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t b/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t index 5ba3e3f..58f18fc 100644 --- a/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t +++ b/lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t @@ -139,8 +139,18 @@ SKIP: { diag(q[Note: 'sudo' might ask for your password to do the install test]) if $conf->get_program('sudo'); - ok( $Mod->install( force =>1 ), + ### make sure no options are set in PERL5_MM_OPT, as they might + ### change the installation target and therefor will 1. mess up + ### the tests and 2. leave an installed copy of our test module + ### lying around. This addresses bug #29716: 20_CPANPLUS-Dist-MM.t + ### fails (and leaves test files installed) when EUMM options + ### include INSTALL_BASE + { local $ENV{'PERL5_MM_OPT'}; + + ok( $Mod->install( force =>1 ), "Installing module" ); + } + ok( $Mod->status->installed," Module installed according to status" ); @@ -255,9 +265,14 @@ SKIP: { " Prior existance noted" ); ### ok, unlink the makefile.pl, now really write one - unlink $makefile; + 1 while unlink $makefile; + + ### must do '1 while' for VMS + { my $unlink_sts = unlink($makefile_pl); + 1 while unlink $makefile_pl; + ok( $unlink_sts, "Deleting Makefile.PL"); + } - 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" ); @@ -283,7 +298,11 @@ SKIP: { ### 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"); + ### must do '1 while' for VMS + { my $unlink_sts = unlink($makefile_pl); + 1 while unlink $makefile_pl; + ok( $unlink_sts, "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" ); @@ -298,8 +317,8 @@ SKIP: { { local $^W; local *CPANPLUS::Dist::MM::write_makefile_pl = sub { 1 }; - unlink $makefile_pl; - unlink $makefile; + 1 while unlink $makefile_pl; + 1 while unlink $makefile; ok(!-s $makefile_pl, "Makefile.PL deleted" ); ok(!-s $makefile, "Makefile deleted" ); @@ -331,9 +350,13 @@ SKIP: { } ### clean up afterwards ### - ok( unlink($makefile_pl), "Deleting Makefile.PL"); + ### must do '1 while' for VMS + { my $unlink_sts = unlink($makefile_pl); + 1 while unlink $makefile_pl; + ok( $unlink_sts, "Deleting Makefile.PL"); + } + $dist->status->mk_flush; - } ### test ENV setting in Makefile.PL diff --git a/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t b/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t index 67730a7..1f71307 100644 --- a/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t +++ b/lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t @@ -104,7 +104,7 @@ my $map = { pre_hook => sub { my $mod = shift; my $clone = $mod->clone; - $clone->status->prereqs( { $ModPrereq => ~0/2 } ); + $clone->status->prereqs( { $ModPrereq => ~0 } ); return $clone; }, failed => 1, @@ -273,6 +273,9 @@ my $map = { } { my $clone = $Mod->clone; + + ### divide by two -- possibly ~0 is unsigned, and we cause an overflow, + ### as happens to version.pm 0.7203 among others. my $prereqs = { $ModPrereq => ~0/2 }; $clone->status->prereqs( $prereqs ); diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed index 78d7f71..1015e11 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed @@ -10,7 +10,7 @@ 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 Wed Aug 15 16:13:41 2007 +Created at Tue Oct 9 17:23:14 2007 ######################################################################### __UU__ M'XL("%_EO$4``S`Q;6%I;')C+G1X=`!+S,E,+%9P#8T(5@`#)=>*DM"2S)QB diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000..55e297c --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,34 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/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/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed + +Created at Tue Oct 9 17:23:14 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(EI?])>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]33SL>%88O">WV/8L4IRX]CG/,@D9']_]/Y'96S;Y/_H?II2/]N+3 +MBZW_3_I?45?^E\OE,6_Z+3QE930LX0I&A +M(MNO&^SL'/+I(I`_B;LN"\FHV>NV5UTW+C+Y$\C!E#IF`*OJ$R'ME&?H#YO-UN6R-0^_DF=(+/_PY;.&1@X,#@!:#&VI9 +M,)ECA[]<4`?8G,`T9*$?=XBOSB$'VT2_JQ`/IR+Z3OR`NHZ^MGU?-HVFOFOK +ML+ET48<+:EDF]0-^:<#W+<@GUR'U2:`C%&TD?#H.690F>EP=DH&C&7&(CQDQ +H1^.%OFE+!,N[@U:L2*)0"00"@4`@$`@$`H%`(-@;?@-?EF['`"@````` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS new file mode 100644 index 0000000..e716d36 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS @@ -0,0 +1,30 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '2917421f5a41419f7bb2d2cf87f04b8d', + 'size' => 1066 + }, + 'perl5.005_03.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '2b70961796a2ed7ca21fbf7e0c615643', + 'size' => 119 + }, + 'Bundle-Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '76f9c0eed0de9f533ed4d3922bac2f11', + 'size' => 850 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme new file mode 100644 index 0000000..ba8894c --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme @@ -0,0 +1,2 @@ +README + diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000..28bec40 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,39 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed + +Created at Tue Oct 9 17:23:14 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+=XF"D'9+72-CDN>@/[+0'_T_+]K[>7_CNE75;[?`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%]-:)&`: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]^]NAY7);EE9&OIO_/O^X)4_^N>SWC9W%J#FN^>Z +M@9Q?K@TP"AU<_\5#X(/D?X^__[.O?]NQ+-3_,2C?_RD\CZ__(`B"(`B"(`B" +?(`B"(`B"(`B"(`B"(`B"(`B"(,@WP=^)5B"Y`%`````` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed new file mode 100644 index 0000000..d720eaa --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed @@ -0,0 +1,18 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed + +Created at Tue Oct 9 17:23:14 2007 +######################################################################### +__UU__ +M'XL(`'3DO44``^W/,0J`,`Q`T1RE)Y"T-O4XXN"DB%2]OR(*NNC4[;_E#\F0 +MS'T>K5*U5FLI1`\IQK--LE { + 'mtime' => '1999-05-13', + 'md5' => 'c7691a12e5faa70b3a0e83402d279bd6', + 'size' => 1589 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme new file mode 100644 index 0000000..ba8894c --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme @@ -0,0 +1,2 @@ +README + diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000..12b23d8 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,51 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed + +Created at Tue Oct 9 17:23:14 2007 +######################################################################### +__UU__ +M'XL("`DY34("`T9O;RU"87(M,"XP,2YT87(`[5IK3]M(%,U7YE=))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_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(LN: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]9QNN]3J9.AQ,4_3:B`_33EH61X.3MS +M.0OH#:<.2XL\T%#`E\<].*MW:_#6OFNW.KU^KW;=A;/T1^M]]A7>?+`[W7JK +M"4AL$I+)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)Y47@`U(@,U;,S:HRI1Y]FQ@C7&O6ACW2VF#[;AMI-MX6W +M(3CE>^:^:G>(6P2]4&]B_5]ZZ+?1_7_Y^&7^MV3JY[^YS0R??>L1".KNGR$J +M0181>_'V.Z]T,;]XEHO+0SZ3[/Q!8I(*=_^JTVKD$Y-D6YD_@%T8N0'*=Z;N +M<0G[SNY?U6_L[J+23_F53%3^\T'6HEI"-&G7Q?_D)8"U[/]??__K)?^/51I8 +M\W\#2-__2CRO7__2T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0 +.T-#X9?`W%LHWQP!0```` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS new file mode 100644 index 0000000..042008c --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS @@ -0,0 +1,20 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '1f52c2e83140814f734c8674e8fae53f', + 'size' => 867 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.readme b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.readme new file mode 100644 index 0000000..ba8894c --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.readme @@ -0,0 +1,2 @@ +README + diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000..712dbb1 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,35 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz.packed + +Created at Tue Oct 9 17:23:14 2007 +######################################################################### +__UU__ +M'XL("-NT](<63\_Z3=.^YV^N;ABO%@R_K^P==X::_?_NK;D_Z9JUM'_BZ"\58O#H";=>48#CY!9 +MX+((MK5J5?O&MEMIGD\AR3]WAY%_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#3>T)E9UN-L7<%15E6-$3G?(IB\*'1,OP1[*+ +MOYA+ER&Z-\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_]QRWAOR;C_^G7WYPUUOF_;C16SG\&QO^%$(QY5GXV3\/[D$REUC[?ZO&\OQ +MGZFIZ/]%L+C_3RR/U_\(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`( +,\D_S"QCQWFL`4``` diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS new file mode 100644 index 0000000..5d2a6d6 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS @@ -0,0 +1,20 @@ +0&&<<''; # this PGP-signed message is also valid perl +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016) +$cksum = { + 'Foo-Bar-0.01.tar.gz' => { + 'mtime' => '1999-05-13', + 'md5' => '986e4316ac095d8a4d47d0d0dd2c408a', + 'size' => 1541 + }, +}; +__END__ +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.3 (GNU/Linux) + +iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1 +mAcaUP8yzmIvbpdn1cGUgpw= +=rrmL +-----END PGP SIGNATURE----- diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme new file mode 100644 index 0000000..ba8894c --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme @@ -0,0 +1,2 @@ +README + diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz.packed new file mode 100644 index 0000000..b52a1f9 --- /dev/null +++ b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz.packed @@ -0,0 +1,50 @@ +######################################################################### +This is a binary file that was packed with the 'uupacktool.pl' which +is included in the Perl distribution. + +To unpack this file use the following command: + + uupacktool.pl -u lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz.packed lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz + +To recreate it use the following command: + + uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz.packed + +Created at Tue Oct 9 17:23:15 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&!,%#!#X!!;'GJ.*]ASRZ2Q/B3B_Z)=/,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/)">`5LE;+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-5Z27BCOU?"]+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/ +MR^(_4WA<_\GI^O]:<&R?5:KP&48^G!J^.Q-/_G\H_KOY;._^O`]HO],/"G +MEJ-_'8A__Q59 +M7O_\Z[=#(OYG/_]9,8]E\6_EOG'_K^L_:P&=\A)U%5SQAQ-XV9[66$K@B?&# +MN@L#V*'+V*B.WJ*2$=T3I&9GQ=0>M08=WQFI%B64(+I&2"5VERGX2'1T2Q#Q +M2K^.RMNMZ5,KZJ^W'AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH: ++R_`55?+KB0!0```` diff --git a/lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed b/lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed index a08b03a..7fadcfa 100644 --- a/lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed +++ b/lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed @@ -10,16 +10,16 @@ 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 Wed Aug 15 16:13:41 2007 +Created at Tue Oct 9 17:23:15 2007 ######################################################################### __UU__ -M'XL("-%#OT4``S`R<&%C:V%G97,N9&5T86EL'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#DXV\+$: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\8>< -B74]^B)L.^MA$CU$'0`E=-1:]LP$`?P=WV* +M>]C#"K&L.IB"GA9GR=B6=&6=:=^*9ET345LRTKE>]NDG-2OMPK)VA\$@GW[Z +M'\A+TZ*$QQ)%KYH[M<'`-9(R;>#T@UC]=?74`UNB7N;Y.(Z\1]_RQG7Y_&)V +MGG=.#RV&_(CR'D/C34_&V:A=[%O`J@X#W+K!:C`6M/'8D/,[>/-@JH&VSH?< +MZ)S-73MT-OR.TC\#)G"//D1X$I=IRSY:0JM19TOG)!349S`]QW,K/:H +M`O_LT)K-.V5-I^+,;!7Y;!YGHK3]5)R5)5NI0%G=ZQ1$PA7J"4P%?%(6"B$* +M$*4LXG,&'];?&%LZ)V6EO)2+6LKK2S@HP<5I>B_JZ\L\-F>Q-TN+G)3GFY_/ +M@'7U+V!=O0HX_W)(/`'IVPM$&N(XL:A?)`[C_P=1Q9L5[[@\1AT0^_;L;])\ + 'Cwd'; use constant TEST_CONF_MODULE => 'Foo::Bar::EU::NOXS'; +use constant TEST_CONF_AUTHOR => 'EUNOXS'; use constant TEST_CONF_INST_MODULE => 'Foo::Bar'; use constant TEST_CONF_INVALID_MODULE => 'fnurk'; use constant TEST_CONF_MIRROR_DIR => 'dummy-localmirror'; +use constant TEST_CONF_CPAN_DIR => 'dummy-CPAN'; ### we might need this Some Day when we're installing into ### our own sandbox. see t/20.t for details @@ -110,13 +137,17 @@ sub gimme_conf { ### for our test suite. Bug [perl #43629] showed this. my $conf = CPANPLUS::Configure->new( load_configs => 0 ); $conf->set_conf( hosts => [ { - path => 'dummy-CPAN', + path => File::Spec->rel2abs(TEST_CONF_CPAN_DIR), scheme => 'file', } ], ); $conf->set_conf( base => 'dummy-cpanplus' ); $conf->set_conf( dist_type => '' ); $conf->set_conf( signature => 0 ); + $conf->set_conf( verbose => 1 ) if $ENV{ $Env }; + + ### never use a pager in the test suite + $conf->set_program( pager => '' ); ### dmq tells us that we should run with /nologo ### if using nmake, as it's very noise otherwise. @@ -157,14 +188,14 @@ sub gimme_conf { sub output_file { return $file } - my $env = 'PERL5_CPANPLUS_TEST_VERBOSE'; + ### redirect output from msg() and error() output to file - unless( $ENV{$env} ) { + unless( $ENV{$Env} ) { print "# To run tests in verbose mode, set ". - "\$ENV{PERL5_CPANPLUS_TEST_VERBOSE} = 1\n" unless $ENV{PERL_CORE}; + "\$ENV{$Env} = 1\n" unless $ENV{PERL_CORE}; - unlink $file; # just in case + 1 while unlink $file; # just in case $CPANPLUS::Error::ERROR_FH = $CPANPLUS::Error::ERROR_FH = output_handle(); @@ -192,8 +223,6 @@ END { } } - - ### whenever we start a new script, we want to clean out our ### old files from the test '.cpanplus' dir.. sub _clean_test_dir { @@ -212,6 +241,23 @@ sub _clean_test_dir { my $path = File::Spec->catfile( $dir, $file ); + ### John Malmberg reports yet another VMS issue: + ### A directory name on VMS in VMS format ends with .dir + ### when it is referenced as a file. + ### In UNIX format traditionally PERL on VMS does not remove the + ### '.dir', however the VMS C library conversion routines do remove + ### the '.dir' and the VMS C library routines can not handle the + ### '.dir' being present on UNIX format filenames. + ### So code doing the fixup has on VMS has to be able to handle both + ### UNIX format names and VMS format names. + ### XXX See http://www.xray.mpe.mpg.de/ + ### mailing-lists/perl5-porters/2007-10/msg00064.html + ### for details -- the below regex could use some touchups + ### according to John. M. + $file =~ s/\.dir//i if $^O eq 'VMS'; + + my $dirpath = File::Spec->catdir( $dir, $file ); + ### directory, rmtree it if( -d $path ) { print "# Deleting directory '$path'\n" if $verbose;