This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update CPANPLUS to 0.83_02
authorRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Wed, 10 Oct 2007 15:36:53 +0000 (15:36 +0000)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Wed, 10 Oct 2007 15:36:53 +0000 (15:36 +0000)
p4raw-id: //depot/perl@32092

41 files changed:
MANIFEST
lib/CPANPLUS.pm
lib/CPANPLUS/Backend.pm
lib/CPANPLUS/Config.pm
lib/CPANPLUS/Internals.pm
lib/CPANPLUS/Internals/Constants.pm
lib/CPANPLUS/Internals/Extract.pm
lib/CPANPLUS/Internals/Report.pm
lib/CPANPLUS/Internals/Search.pm
lib/CPANPLUS/Internals/Source.pm
lib/CPANPLUS/Internals/Utils.pm
lib/CPANPLUS/Selfupdate.pm
lib/CPANPLUS/Shell.pm
lib/CPANPLUS/Shell/Default.pm
lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm [new file with mode: 0644]
lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t
lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t
lib/CPANPLUS/t/04_CPANPLUS-Module.t
lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t
lib/CPANPLUS/t/08_CPANPLUS-Backend.t
lib/CPANPLUS/t/15_CPANPLUS-Shell.t
lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t
lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t
lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed
lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.readme [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/perl5.005_03.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.readme [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.readme [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed
lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed
lib/CPANPLUS/t/inc/conf.pl

index 7a48bee..ef5ba5e 100644 (file)
--- 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
index 52595d2..22cd8d0 100644 (file)
@@ -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:
index 32ed716..8752b71 100644 (file)
@@ -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<CPANPLUS::Configure> 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<CPAN> mirrors, it's 
+possible to add your own sources list to your C<CPANPLUS> index.
+
+The methodology behind this works much like C<Debian's apt-sources>.
+
+The methods below show you how to make use of this functionality. Also
+note that most of these methods are available through the default shell
+plugin command C</cs>, making them available as shortcuts through the
+shell and via the commandline.
+
+=head2 %files = $cb->list_custom_sources
+
+Returns a mapping of registered custom sources and their local indices
+as follows:
+
+    /full/path/to/local/index => http://remote/source
+
+Note that any file starting with an C<#> is being ignored.
+
+=cut
+
+sub list_custom_sources {
+    return shift->__list_custom_module_sources( @_ );
+}
+
+=head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] );
+
+Adds an C<URI> to your own sources list and mirrors its index. See the 
+documentation on C<< $cb->update_custom_source >> on how this is done.
+
+Returns the full path to the local index on success, or false on failure.
+
+Note that when adding a new C<URI>, the change to the in-memory tree is
+not saved until you rebuild or save the tree to disk again. You can do 
+this using the C<< $cb->reload_indices >> method.
+
+=cut
+
+sub add_custom_source {
+    return shift->_add_custom_module_source( @_ );
+}
+
+=head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] );
+
+Removes an C<URI> from your own sources list and removes its index.
+
+To find out what C<URI>s you have as part of your own sources list, use
+the C<< $cb->list_custom_sources >> method.
+
+Returns the full path to the deleted local index file on success, or false
+on failure.
+
+=cut
+
+### XXX do clever dispatching based on arg number?
+sub remove_custom_source {
+    return shift->_remove_custom_module_source( @_ );
+}
+
+=head2 $bool = $cb->update_custom_source( [remote => URI] );
+
+Updates the indexes for all your custom sources. It does this by fetching
+a file called C<packages.txt> in the root of the custom sources's C<URI>.
+If you provide the C<remote> argument, it will only update the index for
+that specific C<URI>.
+
+Here's an example of how custom sources would resolve into index files:
+
+  file:///path/to/sources       =>  file:///path/to/sources/packages.txt
+  http://example.com/sources    =>  http://example.com/sources/packages.txt
+  ftp://example.com/sources     =>  ftp://example.com/sources/packages.txt
+  
+The file C<packages.txt> simply holds a list of packages that can be found
+under the root of the C<URI>. This file can be automatically generated for
+you when the remote source is a C<file:// URI>. For C<http://>, C<ftp://>,
+and similar, the administrator of that repository should run the method
+C<< $cb->write_custom_source_index >> on the repository to allow remote
+users to index it.
+
+For details, see the C<< $cb->write_custom_source_index >> method below.
+
+All packages that are added via this mechanism will be attributed to the
+author with C<CPANID> C<LOCAL>. You can use this id to search for all 
+added packages.
+
+=cut
+
+sub update_custom_source {
+    my $self = shift;
+    
+    ### if it mentions /remote/, the request is to update a single uri,
+    ### not all the ones we have, so dispatch appropriately
+    my $rv = grep( /remote/i, @_)
+        ? $self->__update_custom_module_source( @_ )
+        : $self->__update_custom_module_sources( @_ );
+
+    return $rv;
+}    
+
+=head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] );
+
+Writes the index for a custom repository root. Most users will not have to 
+worry about this, but administrators of a repository will need to make sure
+their indexes are up to date.
+
+The index will be written to a file called C<packages.txt> in your repository
+root, which you can specify with the C<path> argument. You can override this
+location by specifying the C<to> argument, but in normal operation, that should
+not be required.
+
+Once the index file is written, users can then add the C<URI> pointing to 
+the repository to their custom list of sources and start using it right away. See the C<< $cb->add_custom_source >> method for user details.
+
+=cut
+
+sub write_custom_source_index {
+    return shift->__write_custom_module_index( @_ );
+}
+
 1;
 
 =pod
@@ -1040,7 +1182,8 @@ under the same terms as Perl itself.
 
 =head1 SEE ALSO
 
-L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>
+L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>, 
+L<CPANPLUS::Selfupdate>
 
 =cut
 
index fe17881..b092133 100644 (file)
@@ -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' => {
index 7d02eeb..f57facc 100644 (file)
@@ -40,7 +40,7 @@ use vars qw[@ISA $VERSION];
             CPANPLUS::Internals::Report
         ];
 
-$VERSION = "0.82";
+$VERSION = "0.83_02";
 
 =pod
 
index 01dc706..00bf2c5 100644 (file)
@@ -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; ".
index 881ec7b..8063b90 100644 (file)
@@ -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;
     }
index ffcb4f0..cbe20a6 100644 (file)
@@ -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'),
                     );
                     
index 30443f0..2a711ab 100644 (file)
@@ -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;
index f527618..49e0653 100644 (file)
@@ -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<file://> 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<file://> 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<path> 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<to> 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
index 6251608..3f38aaa 100644 (file)
@@ -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<VMS::Filespec::vmsify>
 
 =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<vmsify> 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:
index adcb575..bea8e12 100644 (file)
@@ -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;
index 13cb051..b56adeb 100644 (file)
@@ -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 <bug-cpanplus\@rt.cpan.org>."), "\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
index 08fb19c..2a2e375 100644 (file)
@@ -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<cpanp> binary, or as detailed in the L<SYNOPSIS>.
 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 (file)
index 0000000..e055fbf
--- /dev/null
@@ -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<CPANPLUS::Shell::Default> plugin that can add 
+custom sources to your CPANPLUS installation. This is a 
+wrapper around the C<custom module sources> code as outlined
+in L<CPANPLUS::Backend/CUSTOM MODULE SOURCES>.
+
+This allows you to extend your index of available modules
+beyond what's available on C<CPAN> 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;
+    
index 5634b1a..2b3ad5a 100644 (file)
@@ -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" );
+}    
 
         
         
index b1d5c04..d2ce5cd 100644 (file)
@@ -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
index 7415033..54236e4 100644 (file)
@@ -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");
index 2b09fe2..65bde11 100644 (file)
@@ -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 ) {
index 947ea84..f6be5a7 100644 (file)
@@ -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 ###
index c1e9fbf..09ab382 100644 (file)
+### 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',
+
+    
index 5ba3e3f..58f18fc 100644 (file)
@@ -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
index 67730a7..1f71307 100644 (file)
@@ -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 );
index 78d7f71..1015e11 100644 (file)
@@ -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 (file)
index 0000000..55e297c
--- /dev/null
@@ -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(E<J&5`S6R`,&/8!,E?8(4_UNYD38CTSR+5!9?:$^@;]+3HN[5C_
+MJB0+_7>I?])>VI'^FBR7A?ZO0'_>7MJ%_EI%%?J_$OUY>]&S_U)_35$>U5^5
+MM'O]I2K7OQK7?TGH_\_Q\.0*SP@D>NLZ%US7N>*G"+WY;/3ZK6X'SN`PFA>'
+MO$WFQVAD=#Z,1@B=S0DV9>C4V@9"Z01P%V]T.P.C,^@CM(KINC'4]<L^<*+,
+MZ4BG&\72D7;]L6NBR/HUC1L3TB21Y2/5AH./W1Y"QBT;,FH%/`6^(M'A0\<%
+MGJGAF@3>33SL>%88O">WV/8L4IRX]CG/,@D9']_]/Y'96S;Y/_H?II2/]N+3
+MBZW_3_I?45?^E\OE<KS^2XKP_W:&3V"#"TY1%`B83R>,6_Z+3QE930LX0I&A
+M(MNO&^SL'/+I(I`_B;LN"\FHV>NV5UTW+C+Y$\C!E#IF`*OJ$R<P:<!2]_K)
+MZTK[HF?T^W&ZV0_J0>'ME&?H#YO-UN6R-0^_DF=(+/_P<?_(_GQ,V5J]/^C5
+M&H.U9-=?TX/_=H*.3Z,HVC?_USJMIM$?O.3[WU/^+\O5U/Y/+6O"_UMAHPW1
+MV@J`5K,AF\T.YC0`*_*B.X4H'J"V,:@5%[8%S]%VS9#7#ILP7#`QPW"$39.8
+M,%[`G?F.]W@A_9_6_Z6FV_*_4DV__ZF*I`K_;X,<S!GS]%+)COU9&(?4,HN!
+M&_H3,G7]&2DZA,4SHA!X9%*<,]M"N<L$B`L"_V+P?)>Y;.&1@X,#@!:#&VI9
+M,)ECA[]<4`?8G,`T9*$?=XBOSB$'VT2_JQ`/IR+Z3OR`NHZ^MGU?-HVFOFOK
+ML+ET48<+:EDF]0-^:<#W+<@GUR'U2:`C%&TD?#H.690F>EP=DH&C&7&(CQDQ
+H1^.%OFE+!,N[@U:L2*)0"00"@4`@$`@$`H%`(-@;?@-?EF['`"@`````
diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUNOXS/CHECKSUMS
new file mode 100644 (file)
index 0000000..e716d36
--- /dev/null
@@ -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 (file)
index 0000000..ba8894c
--- /dev/null
@@ -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 (file)
index 0000000..28bec40
--- /dev/null
@@ -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+<O6)`^CP,AX+J9LQL6<
+M&0F3ZXG1RE(V-18RCDCC30&,%V$&ZH="*KCD<I6R>KT.,)#P$$813!<TF3,(
+M$Y`+!K-<YF)ML#Z[01(:,V\3&,JI2-XSD84\*1OTQ*P.W<\$CSW8BT-AHEP8
+M14$H,G5.%DI&!/LC#P7+/$*",),BG.12GZ\OT(-BJ&3.$B:H9,']9.6!_T&^
+MEF&4>=XF"D'9+72-CDN>@/[+0'_T_+]K[>7_CNE<H/Z/HO]Z.\]$6Z_E*1,1
+M(:D($PG/+,.P?D^>75;[?`G%/BZ9_U_]Z\#Z5=S_L6VSB_=_3N)_O;">W/^.
+M:5OH_Y/YOTBLCK7^:]?OK?^NB?7_<2!7"T8#"VYZJOHG(QJGJC9OZ5P<5&T/
+M67%`_4LJR][K\?7MW<9V2!/XOC#[@7U8;XTICU]L[&_'U[XRKW+I*$Q8IBN"
+ME`>0+7@>J=)?E0CSA`L6>.2[7_V[T>#V!JZ@F7`)?.G!7&VK\W4)H,^M-R]5
+M%]-<JI2%3I=4E1GJHCU/S5W5T(!_]:<N*F:)S#[6:0/^4[?E1ZR[;JB2IBA^
+M=&FSW1L\L*9@$'&^#).Y^N[$SJC.FEIKS?.WYKM+@,;6Y;#W-&H&A/Q)]/$'
+M5C7Q)%J!5!5)446I.D?N=CCC>:)&`:K/*8V(+IL^-9Z,37D2[`\K8'I,?Q%B
+M88+WA/,_705\)?F?A<__3N/_S1W=+^M_]S'_.^[^^F]9^/SOI/5_,0U4O8]+
+MPM.)_UM/?[YT_'],_QW7WK__YUHVZO\XPV<?N_6M=/^;""6K9L39.JG41<+V
+MH[RK%]"LDN[F\[5)F7;>]^]NAY7);EE9&OIO_/O^X)4_^N>SWC9W%J#FN^>Z
+M@9Q?K@TP"AU<_\5#X(/D?X^__[.O?]NQ+-3_,2C?_RD\CZ__(`B"(`B"(`B"
+?(`B"(`B"(`B"(`B"(`B"(`B"(,@WP=^)5B"Y`%``````
diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/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 (file)
index 0000000..d720eaa
--- /dev/null
@@ -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<OXM6LJ5/P,8CZ8$'%::F#GK9E[;)S,G13_[7W
+=-[\?N0L`````````````````0$$[-9`]0P`H````
diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/CHECKSUMS
new file mode 100644 (file)
index 0000000..f124759
--- /dev/null
@@ -0,0 +1,20 @@
+0&&<<''; # this PGP-signed message is also valid perl
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+# CHECKSUMS file written on Tue Jun 15 02:56:25 2004 by CPAN::Checksums (v1.016)
+$cksum = {
+  'Foo-Bar-0.01.tar.gz' => {
+    'mtime' => '1999-05-13',
+    'md5' => 'c7691a12e5faa70b3a0e83402d279bd6',
+    'size' => 1589
+  },
+};
+__END__
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.2.3 (GNU/Linux)
+
+iD8DBQFAzmVZMo2oZ0UPiewRAv5MAJ9tajbtrg14echRtn4t940v7FpMfgCffvU1
+mAcaUP8yzmIvbpdn1cGUgpw=
+=rrmL
+-----END PGP SIGNATURE-----
diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme b/lib/CPANPLUS/t/dummy-CPAN/authors/id/EUXS/Foo-Bar-0.01.readme
new file mode 100644 (file)
index 0000000..ba8894c
--- /dev/null
@@ -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 (file)
index 0000000..12b23d8
--- /dev/null
@@ -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=<H%5``A.;
+M/*0@5@0P-"IY*`E=JFX53>))8F%[4L\8B%#_^][Q(P^VI5\VZ78[1P0G]IWG
+MO>?,^-I7G!^>T_"P8!3,H]QZ4$!42B5U-"LE<_F8(6<6+.O8.BX633QO6B6K
+MDH-2;@.(A*0A0.Z>!NPUNQ]=SP:2'7\17"W[_^)=K7EM=]?A_V*Q^'W_6\74
+M_Q@`E3+Z_[ADE7)0T/Y?.^I`?:"0>AY&KL=(3N.WP0K_&[5F_<KN]C:L_Q:*
+M_:K^'Y?+1<W_32`E/NG8M<N&3;(((`UZSY08&.T;@O%A3/WX\"2(9$(:4X\,
+MW.!HQ/E`7?1(P^[5C)GOP8_0X$[D,?"9I(<.E13VJ.,P!P8S4&VJ3[BO)>CG
+M\#]UXAKX7WYE_2\6K27^%Q3_*Y6*YO\FL`L3*:?5HR,_YN7A('(]QQ`\"H=L
+MQ,,Q,P(FX\`X%%,V-";2]\CN70+H35P!^$=A&G+)Y6S*MK>W`>H2'EW/@^&$
+M!F,&;@!RPF`4R2B,#>+2NR2@/JO.E2$-1?+`0N'R(+V@`C,[U1^%W*]"JD=N
+M@*[S/,<-!=H*5S(2LB^1&S)1)<1QA0S=0215.=6Q*B1#)&,6L)!*YO0'LRK8
+M3_)6NIZH5N?R`VES4#:L$OF-^)]*^SKV_Z77[O\JA1?[_V*A9&G^;P+G]G6]
+M"<_(7S>0L&,:AOE7L`-?3T@DF*)DM8KA<4+2Z_P>U/43O4#_'_FOMG3_B?S/
+ML571^9^?X__YEGZ#^E\LO=#_DFGJ_,]F]G_;1Y$(8\]/6>B13.B3,$"A)Z86
+M^]]%_Y,[_+7H_VO\MY#S+_*_9:NL^;\1_KO!T(L<!COV7<_N-(W)#EF<4Y*P
+M>N:N>WNNSI!&Z_+VQH;3^1YQ:ZM=NWA?NUX]1_`V31)7]-D#"_;<8!K)?;*E
+M)$8A_DW4MXO6I5TE6QV[]Z%V@S4DIO`6+#@]A<+^26S5NNVU;WMS.RU,_S[_
+MI_ZF^6]9Q<H_^&\6-/\W@2D=WM/Q\IV>NN]3J9.AQ,4_3:B`_33EH61X.3MS
+M.0OH#:<.2XL\T%#`E\<].*MW:_#6OFNW.KU^KW;=A;/T1^M]]A7>?+`[W7JK
+M"4AL$I<X586S9I9J5P:[4)?,%R`YL-@"A0._#ZGG,6Q5I9$$#H2I)++#1C3R
+MI`%-+ED5'`X!EVDQK"BV7;*#1U=.."H-55F?&8PY=R!D5/#`@%L<UZ+O*M_$
+MJ&-@+9=)K<+UI]XLZQ/V!F8\"F$:#3QW"*,H&*KLDSCR&;;AB*,A5RFK0`I#
+MC2E.GF$A_BBP-T./AE29;ZG9O.OVF)"0K^+U_(F:@)&J.QM.P)@#$LL?@,\?
+MW&"L?@1CK`==,Y38IWB"LMGFX9(/L+(X-R?H@TK#^SR<&63%7ZB^D%<-P^D?
+M\$GYA6R1??B<.&LQ(<KN[!G>+)5]CLM]A:_+MHEO51TG9.[X4\@KS<'!D0'G
+M$B..3N=1.(^/V/GMD'DJ%AQ()Q*]!!,6,B/>G?;[=O.RWT?#<[1[5/E((:,!
+MSM4P\ED@XUF%$4Y"[)TD"VC`1YS.`9,JVICC8DC);4).)^AA$YJUADU(ZH1#
+M:.,RB%Z6+!!950./3A;_Y@6['YNM=K?>);A<+?RH%J_O%+BTNQ>=>KN'8R6D
+M^^UN)Y4<P!#C4B:/2B;6DS!4FM7C_%Z`Y]XSE6(E-,()"H&/XH3KHLN/%&G"
+MQIX[QIJ!!3P:3Q2=/*:B0-FJ*2-1H*:"88R3\Y7^&FF'K90/A#1YL,(W,A]2
+M[;;WKM4AI(8$,C#*>7@`U(@,U;,S:HRI1Y]FQ@C7&O6ACW2VF#[;AMI-MX6W
+M(3CE>^:^:G>(6P2]4&]B_5]ZZ+?1_7_Y^&7^MV3JY[^YS0R??>L1".KNGR$J
+M0181>_'V.Z]T,;]XEHO+0SZ3[/Q!8I(*=_^JTVKD$Y-D6YD_@%T8N0'*=Z;N
+M<0G[SNY?U6_L[J+23_F53%3^\T'6HEI"-&G7Q?_D)8"U[/]??__K)?^/51I8
+M\W\#2-__2CRO7__2T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0
+.T-#X9?`W%LHWQP!0````
diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBNOXS/CHECKSUMS
new file mode 100644 (file)
index 0000000..042008c
--- /dev/null
@@ -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 (file)
index 0000000..ba8894c
--- /dev/null
@@ -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 (file)
index 0000000..712dbb1
--- /dev/null
@@ -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("-<X34(``T9O;RU"87(M,"XP,2YT87(`[9E;;]HP%,=Y]J<X+9722@-R
+M!0G6:G2#M=)*I]+MI:M0((9&)#;*I5TU[;O/)J1JH!WK%-)U/;\7XTOXVSD^
+M]G'<Y;QR:`<5M:IJM=)F4`4-RY*IUK"T^VE*25-UW=`-T]`;)573+<,J@;6A
+M_F2(P\@.`$I3F]'?M5M7GPXD35\(W?OV?W_4[GWL]//6D.^C;IJ/VU\WE^QO
+M6*(("GF)K]S^QV#[8,/"\C!V/4J>NT](<63\_Z3=.^YV^N<Y:ZSS?TVM+_M_
+MO6Z@_Q?!PO')6:?]X:1##F/7<ZJ?/Y%T*I"(AE%UYA'/'=;$9*F)R5*=^63H
+MLMJ8\Z',>;ABO%@R_K^P==X::_?_NK;D_Z9JUM'_BZ"\58O#H";=>48#CY!9
+MX+((MK5J5?O&MEMIGD\AR3]WAY%<R?B_7.,WH/'T\Y]AJ`:>_XI@Q?YRC\]9
+MX^GV-U6]CO8O@@?MG\1XN6FLV?^EZ9?L;ZD8_Q<#V;^BMJ-!KRVB?]*W_9E'
+MH0)B%H`([R%,"L1/DK9L?SD_.CV[:WMB,WB;-'M'O\_3ZHC[!W?M3\^/.J+Y
+M-0U"ES/P7$9#<!G,N`/A%8\]!X84W`GC`76:9.=KYZQ_?-J#?5`8CX!/FS`1
+M:?K\.."^?'9+:0F)41R)D,4>3>T)E9UN-L7<%15E6-$3G?(IB\*'1,OP1[*+
+MOYA+ER&Z<L4?AR*E&36XH4I`P>-\ZK*)>'=!9E2[BO0U9>]"O6P!E.]UAU[;
+MGN(0\H/(\AN:5G'FW4)D3^E<:NP&8905'/.8B5&`T!S9GDCAT?&$=,29LSPL
+MA\HQ_21$PP#O=9%9_^4I8`,:?Q7_X??_0EBQ_]U'G?PTUI[_36MY_]<T#??_
+M(GCL_)],`W'>QRWAOR;C_^G7WYPUUOF_;C16SG\&QO^%$(<BA.=.[%$1.DOS
+MMX`0_Q9VAC(CHD=&;[(-1'BY*T-,?UXX8+9/8?\`E#3Z5M[(VG`4N+-H(.\3
+M0UE]`4IF=U'@4K;;:Y%$J7(P"J@=T<$\-T@>QY5GXV3\/[D$REUC[?ZO&\OQ
+MGZFIZ/]%L+C_3RR/U_\(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`(@B`(
+,\D_S"QCQWFL`4```
diff --git a/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS b/lib/CPANPLUS/t/dummy-CPAN/authors/id/MBXS/CHECKSUMS
new file mode 100644 (file)
index 0000000..5d2a6d6
--- /dev/null
@@ -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 (file)
index 0000000..ba8894c
--- /dev/null
@@ -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 (file)
index 0000000..b52a1f9
--- /dev/null
@@ -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&<O*6ME<-EO8R)A6
+M/GNP`?DGDB>!,%#<!]BXX9[X.[IE[;.)S#Y_$KQ9M/_)VW+US&ZLF@?IXR"7
+M^[[]K=P#^V?S5GX#UJ+$W]S^%>!#X!!;'GJ.*]ASRZ2Q/B3B_Z)<K;RQ&\T5
+M\U@6_R8F^P?Q?W!0T/&_#K0=;[\G99O[QLAEQZ'C=HWZ.8OS`7.=]CZZR/XQ
+MM0\3CW<!F_D+N[3+IQ<V4R)0-,R%W2P;DZ&K,\G_'HGX)_,^`8\?W_]ELYF<
+MWO^M`X_L3^&]8AX_;O]<QBIH^Z\#W[1_E-Y7QF/9^F\5'J[_>=/,Z?5_'=AV
+MO(X;=@5LV==-^[)J#+;8_;N1\-WDF^O&U3&]81>UTZMS&TJ`#E,LHL=L;M;+
+M)^_*9\EWC#F>8D[0$K?"VW&\4:AVV2:^`\+TF=&WD]JI762;EW;S??D<1XA(
+MX1584"I!9O=P2E6[:M:OFG,ZO;_XS_AN_(^&*^.Q)/XM*U=X&/\93`DZ_M>`
+M$>_<\+Z81^PA"P,!@?*=CCIDS!>?0L<78-^-I*\$-L_>G$X\?BYY5\1=;KD?
+MP*?Q#AQ5&F5X95_7:Y?-5K-\UH"C^*'V;O857KZW+QN56A4PL-FT1XDZS]@L
+MC$X$VU!18AB`DB"F%)@X\'N'NZY`KAX?B@`G(J`]@:[H\=!5!E2E$D7H2O"D
+MBKOA0%/:!3H8.VH@,=-PN!7^!/I2=L$7/)">`5<XKWO9'2]0@G<-'.4T&C5P
+MAB-W,I,)I8&)#'T8A6W7Z4`O]#K*D5ZP/Q3(HQOL=_!!<4\%!LVI.7`"ZB3'
+M`4K3<;G/B7R3M'G=:.)9"E)%;$\=D@)Z-/9L.IX075#8?P^&\M;Q^O3@]7$<
+M-$U'H4Q3!<VT+?T%&^!@8P=%#?BM@*$82G]BL(2],/M"BAA#Z37\279AFVP7
+M/D;&NE<(T1U]AI<+?3]/^WV!+XNTD6UIC$,V-WP)4I1S<'*L+:5"C^.CN1?.
+M_6-J_+HO7/*%+L2*1"O!0/@"U6@>LE;+KIZV6DAXC'1C0*T&*FRCKCKA4'AJ
+MJE7HH1*FUAG*;N@*`SZ@.MM"D;>)KH,NI5XP5AJ@A4VHEO$TRV(CI*&.RR!:
+M60DOF`W5=OG@_M^\8^-#M59O5!H,EZM[.]+B]9T.IW;CY+)2;^)<&6M\6^QH
+MD#WHH%\JU`)Z[\"Z"PR,"G"EO`G`=6X$NH!@/$0%^2![]+0@\IACF(B^Z_1Q
+M9!">#/L#"B=7D!<0+:F,A1ZI0J"/L^.$O$8LL!7'`V-5Z27BC<VG5+YJOJU=
+M,E;&`#+0RZ6_!]P(#9+LB!M][O*[B='#-8;^^)A/[M5GVU`^;]08HYW'CKE+
+M?#NX17CN-/G+(EG_B^LV*^:Q;/^?S68?G?\R>OU?"]+I-&Q_*%^<%TTCPVAU
+M+$+L$PP71$H>12#GB%-+$5-9&GX@M'F;4GM'%?]!%L55$QM1@M"[\>388YBM
+MA$\YK]6>%.%BFKEQ@:`J)<32H7#60>8/<V^^DM-LJ%CYW*K]*9"(_[A^NVH>
+MR^(_4WA<_\GI^O]:<&R?5:KP&48^G<FW3,,P__*VX$NTJ;\_%<3M\@:H_5`'
+MUR^"1/S39=`3\/A7]7_]^X^UX)']YY>!J^.Q-/_G\H_KOY;._^O`]HO],/"G
+MEJ<C%YLE^L@-,-'3"?NYA=1X,B3B/[K&7SF/I?%O/3S_97.FJ>-_'8A__Q59
+M7O_\Z[=#(OYG/_]9,8]E\6_EOG'_K^L_:P&=\A)U%5SQAQ-XV9[66$K@B?&#
+MN@L#V*'+V*B.WJ*2$=T3I&9GQ=0>M08=WQFI%B64(+I&2"5VERGX2'1T2Q#Q
+M2K^.RMNMZ5,KZJ^W'AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:&AH:
++R_`55?+KB0!0````
index a08b03a..7fadcfa 100644 (file)
@@ -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<RYT>'0`E=-1:]LP$`#@=_^*
-M>]C#!K&D.IB"GAJGR=B6=&5M:-^&:ET3,5LRTKE>]NLG-2TM(6FWX\!@WWVZ
-M`WEN&I3P'*+H5/U+K3$PC:1,$QC]IFSU8_%2`QNB3G(^#`/KT#>L=BV?7DXN
-M>.MTWV#@1Y1S#+4W'1EGHW:Y*P&K6@QP[WJKP5C0QF--SF_APZ.I>MHX'[C1
-M/)NZIF]M>!JE>P6,X`%]B/`HOJ9-]L426HTZGSLO8=*3:Q6AAGND>@/>]60L
-MAM'N\`@A:%?W+5I2:3R6W7A#D<BK;3JM;;0)-*C4_/$!"C86Q2>XV\+$:H\J
-ML&\.K5F?*6M:%7?.%I'/IW$G2NTGXK0LLX4*E*\ZG0:1<(-Z!&,!7Y6%0H@"
-M1"F+F*?P>7F=97/GI*R4EW*VDO+V"O9",'&2GC,^6\6\O>*Q(X\->?K"2'FV
-M_O-*659O*4N^K&+^DW+Q?=_94U+!.T[:Z;CSM-.[SOXV_^M4\<K%RR^/>8><
-B74]^B)L.^MA$CU$<X-+_4S(ARI]B_.QD?P$Z!("8DP,`````
+M'XL("%^M`T<``S`R<&%C:V%G97,N9&5T86EL<RYT>'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)<P&<ITBU'"+U&S!NX&,
+MQ3#9'QXA!.V:H4-+*L7C[,H;BD16[=)I7:M-H%&ES6_OH>!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;])\
+<U,=R/%3QIY1^CI(+4=Z(Z2/!?@$#U+EW<`,`````
index f346e34..5bafcc1 100644 (file)
@@ -10,7 +10,7 @@ To recreate it use the following command:
 
      uupacktool.pl -p lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed
 
-Created at Wed Aug 15 16:13:41 2007
+Created at Tue Oct  9 17:23:15 2007
 #########################################################################
 __UU__
 M'XL("#'FO$4``S`S;6]D;&ES="YD871A`%U3_6O;,!#].?HKCBXC"20A=<@&
index 497a912..5065116 100644 (file)
@@ -1,3 +1,6 @@
+### On VMS, the ENV is not reset after the program terminates.
+### So reset it here explicitly
+my ($old_env_path, $old_env_perl5lib);
 BEGIN {
     use FindBin; 
     use File::Spec;
@@ -20,12 +23,14 @@ BEGIN {
     use Config;
 
     ### and add them to the environment, so shellouts get them
-    $ENV{'PERL5LIB'} = join ':', 
+    $old_env_perl5lib = $ENV{'PERL5LIB'};
+    $ENV{'PERL5LIB'}  = join ':', 
                         grep { defined } $ENV{'PERL5LIB'}, @paths, @rel2abs;
     
     ### add our own path to the front of $ENV{PATH}, so that cpanp-run-perl
     ### and friends get picked up
-    $ENV{'PATH'} = join $Config{'path_sep'}, 
+    $old_env_path = $ENV{PATH};
+    $ENV{'PATH'}  = join $Config{'path_sep'}, 
                     grep { defined } "$FindBin::Bin/../bin", $ENV{'PATH'};
 
     ### Fix up the path to perl, as we're about to chdir
@@ -49,6 +54,24 @@ BEGIN {
     $IPC::Cmd::USE_IPC_RUN = 0 if $^O eq 'MSWin32';
 }
 
+### Use a $^O comparison, as depending on module at this time
+### may cause weird errors/warnings
+END {
+    if ($^O eq 'VMS') {
+        ### VMS environment variables modified by this test need to be put back
+        ### path is "magic" on VMS, we can not tell if it really existed before
+        ### this was run, because VMS will magically pretend that a PATH
+        ### environment variable exists set to the current working directory
+        $ENV{PATH} = $old_path;
+
+        if (defined $old_perl5lib) {
+            $ENV{PERL5LIB} = $old_perl5lib;
+        } else {
+            delete $ENV{PERL5LIB};
+        }
+    }
+}
+
 use strict;
 use CPANPLUS::Configure;
 use CPANPLUS::Error ();
@@ -62,12 +85,16 @@ use File::Basename  qw[basename];
     $Locale::Maketext::Lexicon::VERSION = 0;
 }
 
+my $Env = 'PERL5_CPANPLUS_TEST_VERBOSE';
+
 # prereq has to be in our package file && core!
 use constant TEST_CONF_PREREQ           => 'Cwd';   
 use constant TEST_CONF_MODULE           => 'Foo::Bar::EU::NOXS';
+use constant TEST_CONF_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;