This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add CPANPLUS 0.78
authorRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Tue, 10 Apr 2007 07:42:33 +0000 (07:42 +0000)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Tue, 10 Apr 2007 07:42:33 +0000 (07:42 +0000)
p4raw-id: //depot/perl@30883

97 files changed:
MANIFEST
installperl
lib/CPANPLUS.pm [new file with mode: 0644]
lib/CPANPLUS/Backend.pm [new file with mode: 0644]
lib/CPANPLUS/Backend/RV.pm [new file with mode: 0644]
lib/CPANPLUS/Config.pm [new file with mode: 0644]
lib/CPANPLUS/Configure.pm [new file with mode: 0644]
lib/CPANPLUS/Configure/Setup.pm [new file with mode: 0644]
lib/CPANPLUS/Dist.pm [new file with mode: 0644]
lib/CPANPLUS/Dist/Base.pm [new file with mode: 0644]
lib/CPANPLUS/Dist/MM.pm [new file with mode: 0644]
lib/CPANPLUS/Dist/Sample.pm [new file with mode: 0644]
lib/CPANPLUS/Error.pm [new file with mode: 0644]
lib/CPANPLUS/FAQ.pod [new file with mode: 0644]
lib/CPANPLUS/Hacking.pod [new file with mode: 0644]
lib/CPANPLUS/Internals.pm [new file with mode: 0644]
lib/CPANPLUS/Internals/Constants.pm [new file with mode: 0644]
lib/CPANPLUS/Internals/Constants/Report.pm [new file with mode: 0644]
lib/CPANPLUS/Internals/Extract.pm [new file with mode: 0644]
lib/CPANPLUS/Internals/Fetch.pm [new file with mode: 0644]
lib/CPANPLUS/Internals/Report.pm [new file with mode: 0644]
lib/CPANPLUS/Internals/Search.pm [new file with mode: 0644]
lib/CPANPLUS/Internals/Source.pm [new file with mode: 0644]
lib/CPANPLUS/Internals/Utils.pm [new file with mode: 0644]
lib/CPANPLUS/Internals/Utils/Autoflush.pm [new file with mode: 0644]
lib/CPANPLUS/Module.pm [new file with mode: 0644]
lib/CPANPLUS/Module/Author.pm [new file with mode: 0644]
lib/CPANPLUS/Module/Author/Fake.pm [new file with mode: 0644]
lib/CPANPLUS/Module/Checksums.pm [new file with mode: 0644]
lib/CPANPLUS/Module/Fake.pm [new file with mode: 0644]
lib/CPANPLUS/Module/Signature.pm [new file with mode: 0644]
lib/CPANPLUS/Selfupdate.pm [new file with mode: 0644]
lib/CPANPLUS/Shell.pm [new file with mode: 0644]
lib/CPANPLUS/Shell/Classic.pm [new file with mode: 0644]
lib/CPANPLUS/Shell/Default.pm [new file with mode: 0644]
lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod [new file with mode: 0644]
lib/CPANPLUS/Shell/Default/Plugins/Remote.pm [new file with mode: 0644]
lib/CPANPLUS/Shell/Default/Plugins/Source.pm [new file with mode: 0644]
lib/CPANPLUS/bin/cpan2dist [new file with mode: 0644]
lib/CPANPLUS/bin/cpanp [new file with mode: 0644]
lib/CPANPLUS/bin/cpanp-run-perl [new file with mode: 0644]
lib/CPANPLUS/inc.pm [new file with mode: 0644]
lib/CPANPLUS/t/00_CPANPLUS-Inc.t [new file with mode: 0644]
lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t [new file with mode: 0644]
lib/CPANPLUS/t/01_CPANPLUS-Configure.t [new file with mode: 0644]
lib/CPANPLUS/t/02_CPANPLUS-Internals.t [new file with mode: 0644]
lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t [new file with mode: 0644]
lib/CPANPLUS/t/04_CPANPLUS-Module.t [new file with mode: 0644]
lib/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t [new file with mode: 0644]
lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t [new file with mode: 0644]
lib/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t [new file with mode: 0644]
lib/CPANPLUS/t/08_CPANPLUS-Backend.t [new file with mode: 0644]
lib/CPANPLUS/t/09_CPANPLUS-Internals-Search.t [new file with mode: 0644]
lib/CPANPLUS/t/10_CPANPLUS-Error.t [new file with mode: 0644]
lib/CPANPLUS/t/19_CPANPLUS-Dist.t [new file with mode: 0644]
lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t [new file with mode: 0644]
lib/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t [new file with mode: 0644]
lib/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t [new file with mode: 0644]
lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.readme [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.readme [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.readme [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.readme [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/01mailrc.txt.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/02packages.details.txt.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/03modlist.data.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/CHECKSUMS [new file with mode: 0644]
lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed [new file with mode: 0644]
lib/CPANPLUS/t/inc/conf.pl [new file with mode: 0644]
utils.lst
utils/Makefile
utils/cpan2dist.PL [new file with mode: 0644]
utils/cpanp-run-perl.PL [new file with mode: 0644]
utils/cpanp.PL [new file with mode: 0644]
win32/Makefile
win32/makefile.mk

index 12caf9e..adae648 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1571,6 +1571,98 @@ lib/CPAN/Nox.pm                  Runs CPAN while avoiding compiled extensions
 lib/CPAN/PAUSE2003.pub         CPAN public key
 lib/CPAN/PAUSE2005.pub         CPAN public key
 lib/CPAN/PAUSE2007.pub         CPAN public key
+lib/CPANPLUS/Backend.pm        CPANPLUS
+lib/CPANPLUS/Backend/RV.pm     CPANPLUS
+lib/CPANPLUS/bin/cpan2dist     the cpan2dist utility
+lib/CPANPLUS/bin/cpanp the cpanp utility
+lib/CPANPLUS/bin/cpanp-run-perl        the cpanp-run-perl utility
+lib/CPANPLUS/Config.pm CPANPLUS
+lib/CPANPLUS/Configure.pm      CPANPLUS
+lib/CPANPLUS/Configure/Setup.pm        CPANPLUS
+lib/CPANPLUS/Dist/Base.pm      CPANPLUS
+lib/CPANPLUS/Dist/MM.pm        CPANPLUS
+lib/CPANPLUS/Dist.pm   CPANPLUS
+lib/CPANPLUS/Dist/Sample.pm    CPANPLUS
+lib/CPANPLUS/Error.pm  CPANPLUS
+lib/CPANPLUS/FAQ.pod   CPANPLUS
+lib/CPANPLUS/Hacking.pod       CPANPLUS
+lib/CPANPLUS/inc.pm    CPANPLUS
+lib/CPANPLUS/Internals/Constants.pm    CPANPLUS
+lib/CPANPLUS/Internals/Constants/Report.pm     CPANPLUS
+lib/CPANPLUS/Internals/Extract.pm      CPANPLUS
+lib/CPANPLUS/Internals/Fetch.pm        CPANPLUS
+lib/CPANPLUS/Internals.pm      CPANPLUS
+lib/CPANPLUS/Internals/Report.pm       CPANPLUS
+lib/CPANPLUS/Internals/Search.pm       CPANPLUS
+lib/CPANPLUS/Internals/Source.pm       CPANPLUS
+lib/CPANPLUS/Internals/Utils/Autoflush.pm      CPANPLUS
+lib/CPANPLUS/Internals/Utils.pm        CPANPLUS
+lib/CPANPLUS/Module/Author/Fake.pm     CPANPLUS
+lib/CPANPLUS/Module/Author.pm  CPANPLUS
+lib/CPANPLUS/Module/Checksums.pm       CPANPLUS
+lib/CPANPLUS/Module/Fake.pm    CPANPLUS
+lib/CPANPLUS/Module.pm CPANPLUS
+lib/CPANPLUS/Module/Signature.pm       CPANPLUS
+lib/CPANPLUS.pm        CPANPLUS
+lib/CPANPLUS/Selfupdate.pm     CPANPLUS
+lib/CPANPLUS/Shell/Classic.pm  CPANPLUS
+lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod   CPANPLUS
+lib/CPANPLUS/Shell/Default/Plugins/Remote.pm   CPANPLUS
+lib/CPANPLUS/Shell/Default/Plugins/Source.pm   CPANPLUS
+lib/CPANPLUS/Shell/Default.pm  CPANPLUS
+lib/CPANPLUS/Shell.pm  CPANPLUS
+lib/CPANPLUS/t/00_CPANPLUS-Inc.t       CPANPLUS tests
+lib/CPANPLUS/t/00_CPANPLUS-Internals-Utils.t   CPANPLUS tests
+lib/CPANPLUS/t/01_CPANPLUS-Configure.t CPANPLUS tests
+lib/CPANPLUS/t/02_CPANPLUS-Internals.t CPANPLUS tests
+lib/CPANPLUS/t/03_CPANPLUS-Internals-Source.t  CPANPLUS tests
+lib/CPANPLUS/t/04_CPANPLUS-Module.t    CPANPLUS tests
+lib/CPANPLUS/t/05_CPANPLUS-Internals-Fetch.t   CPANPLUS tests
+lib/CPANPLUS/t/06_CPANPLUS-Internals-Constants.t       CPANPLUS tests
+lib/CPANPLUS/t/07_CPANPLUS-Internals-Extract.t CPANPLUS tests
+lib/CPANPLUS/t/08_CPANPLUS-Backend.t   CPANPLUS tests
+lib/CPANPLUS/t/09_CPANPLUS-Internals-Search.t  CPANPLUS tests
+lib/CPANPLUS/t/10_CPANPLUS-Error.t     CPANPLUS tests
+lib/CPANPLUS/t/19_CPANPLUS-Dist.t      CPANPLUS tests
+lib/CPANPLUS/t/20_CPANPLUS-Dist-MM.t   CPANPLUS tests
+lib/CPANPLUS/t/21_CPANPLUS-Dist-No-Build.t     CPANPLUS tests
+lib/CPANPLUS/t/30_CPANPLUS-Internals-Selfupdate.t      CPANPLUS tests
+lib/CPANPLUS/t/40_CPANPLUS-Internals-Report.t  CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/01mailrc.txt.gz.packed       CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed     CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/CHECKSUMS     CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.readme   CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed    CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed    CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/CHECKSUMS       CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.readme     CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed      CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/CHECKSUMS     CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.readme   CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed    CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/CHECKSUMS       CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.readme     CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed      CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/modules/02packages.details.txt.gz.packed     CPANPLUS tests
+lib/CPANPLUS/t/dummy-CPAN/modules/03modlist.data.gz.packed     CPANPLUS tests
+lib/CPANPLUS/t/dummy-cpanplus/01mailrc.txt.gz.packed   CPANPLUS tests
+lib/CPANPLUS/t/dummy-cpanplus/02packages.details.txt.gz.packed CPANPLUS tests
+lib/CPANPLUS/t/dummy-cpanplus/03modlist.data.gz.packed CPANPLUS tests
+lib/CPANPLUS/t/dummy-cpanplus/sourcefiles.2.15.stored.packed   CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/01mailrc.txt.gz.packed        CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/02packages.details.txt.gz.packed      CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/03modlist.data.gz.packed      CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Bundle-Foo-Bar-0.01.tar.gz.packed      CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/CHECKSUMS      CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/Foo-Bar-0.01.tar.gz.packed     CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUNOXS/perl5.005_03.tar.gz.packed     CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/CHECKSUMS        CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/authors/id/E/EU/EUXS/Foo-Bar-0.01.tar.gz.packed       CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/CHECKSUMS      CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBNOXS/Foo-Bar-0.01.tar.gz.packed     CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/CHECKSUMS        CPANPLUS tests
+lib/CPANPLUS/t/dummy-localmirror/authors/id/M/MB/MBXS/Foo-Bar-0.01.tar.gz.packed       CPANPLUS tests
+lib/CPANPLUS/t/inc/conf.pl     CPANPLUS tests
 lib/CPAN.pm                    Interface to Comprehensive Perl Archive Network
 lib/CPAN/Queue.pm              queueing system for CPAN.pm
 lib/CPAN/SIGNATURE             CPAN public key
@@ -2398,8 +2490,8 @@ lib/Pod/Simple/t/html02.t Pod::Simple test file
 lib/Pod/Simple/t/html03.t      Pod::Simple test file
 lib/Pod/Simple/t/htmlbat.t     Pod::Simple test file
 lib/Pod/Simple/TiedOutFH.pm    Pod::Simple::TiedOutFH
-lib/Pod/Simple/t/items.t       Pod::Simple test file
 lib/Pod/Simple/t/items02.t     Pod::Simple test file
+lib/Pod/Simple/t/items.t       Pod::Simple test file
 lib/Pod/Simple/t/itemstar.t    Pod::Simple test file
 lib/Pod/Simple/t/junk1o.txt    Pod::Simple test file
 lib/Pod/Simple/t/junk1.pod     Pod::Simple test file
@@ -3784,7 +3876,10 @@ util.h                           Dummy header
 utils/c2ph.PL                  program to translate dbx stabs to perl
 utils/config_data.PL           Module::Build tool
 utils/corelist.PL              Module::CoreList
+utils/cpan2dist.PL     the cpan2dist utility
 utils/cpan.PL                  easily interact with CPAN from the command line
+utils/cpanp.PL the cpanp utility
+utils/cpanp-run-perl.PL        the cpanp-run-perl utility
 utils/dprofpp.PL               Perl code profile post-processor
 utils/enc2xs.PL                        Encode module generator
 utils/h2ph.PL                  A thing to turn C .h files into perl .ph files
index 0123e53..f4742ee 100755 (executable)
@@ -830,7 +830,7 @@ sub installlib {
     # the corelist script from lib/Module/CoreList/bin and ptar* in
     # lib/Archive/Tar/bin, the config_data script in lib/Module/Build/scripts
     # (they're installed later with other utils)
-    return if $name =~ /^(?:cpan|instmodsh|prove|corelist|ptar|ptardiff|config_data)\z/;
+    return if $name =~ /^(?:cpan|instmodsh|prove|corelist|ptar|cpan2dist|cpanp|cpanp-run-perl|ptardiff|config_data)\z/;
     # ignore the Makefiles
     return if $name =~ /^makefile$/i;
     # ignore the test extensions
diff --git a/lib/CPANPLUS.pm b/lib/CPANPLUS.pm
new file mode 100644 (file)
index 0000000..b30aa7f
--- /dev/null
@@ -0,0 +1,271 @@
+package CPANPLUS;
+
+use strict;
+use Carp;
+
+use CPANPLUS::Error;
+use CPANPLUS::Backend;
+
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+
+BEGIN {
+    use Exporter    ();
+    use vars        qw( @EXPORT @ISA $VERSION );
+    @EXPORT     =   qw( shell fetch get install );
+    @ISA        =   qw( Exporter );
+    $VERSION = "0.78";     #have to hardcode or cpan.org gets unhappy
+}
+
+### purely for backward compatibility, so we can call it from the commandline:
+### perl -MCPANPLUS -e 'install Net::SMTP'
+sub install {
+    my $cpan = CPANPLUS::Backend->new;
+    my $mod = shift or (
+                    error(loc("No module specified!")), return
+                );
+
+    if ( ref $mod ) {
+        error( loc( "You passed an object. Use %1 for OO style interaction",
+                    'CPANPLUS::Backend' ));
+        return;
+
+    } else {
+        my $obj = $cpan->module_tree($mod) or (
+                        error(loc("No such module '%1'", $mod)),
+                        return
+                    );
+
+        my $ok = $obj->install;
+
+        $ok
+            ? msg(loc("Installing of %1 successful", $mod),1)
+            : msg(loc("Installing of %1 failed", $mod),1);
+
+        return $ok;
+    }
+}
+
+### simply downloads a module and stores it
+sub fetch {
+    my $cpan = CPANPLUS::Backend->new;
+
+    my $mod = shift or (
+                    error(loc("No module specified!")), return
+                );
+
+    if ( ref $mod ) {
+        error( loc( "You passed an object. Use %1 for OO style interaction",
+                    'CPANPLUS::Backend' ));
+        return;
+
+    } else {
+        my $obj = $cpan->module_tree($mod) or (
+                        error(loc("No such module '%1'", $mod)),
+                        return
+                    );
+
+        my $ok = $obj->fetch( fetchdir => '.' );
+
+        $ok
+            ? msg(loc("Fetching of %1 successful", $mod),1)
+            : msg(loc("Fetching of %1 failed", $mod),1);
+
+        return $ok;
+    }
+}
+
+### alias to fetch() due to compatibility with cpan.pm ###
+sub get { fetch(@_) }
+
+
+### purely for backwards compatibility, so we can call it from the commandline:
+### perl -MCPANPLUS -e 'shell'
+sub shell {
+    my $option  = shift;
+
+    ### since the user can specify the type of shell they wish to start
+    ### when they call the shell() function, we have to eval the usage
+    ### of CPANPLUS::Shell so we can set up all the checks properly
+    eval { require CPANPLUS::Shell; CPANPLUS::Shell->import($option) };
+    die $@ if $@;
+
+    my $cpan = CPANPLUS::Shell->new();
+
+    $cpan->shell();
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+CPANPLUS - API & CLI access to the CPAN mirrors
+
+=head1 SYNOPSIS
+
+    ### standard invocation from the command line
+    $ cpanp
+    $ cpanp -i Some::Module
+
+    $ perl -MCPANPLUS -eshell
+    $ perl -MCPANPLUS -e'fetch Some::Module'
+
+    
+=head1 DESCRIPTION
+
+The C<CPANPLUS> library is an API to the C<CPAN> mirrors and a
+collection of interactive shells, commandline programs, etc,
+that use this API.
+
+=head1 GUIDE TO DOCUMENTATION
+
+=head2 GENERAL USAGE
+
+This is the document you are currently reading. It describes 
+basic usage and background information. Its main purpose is to 
+assist the user who wants to learn how to invoke CPANPLUS
+and install modules from the commandline and to point you
+to more indepth reading if required.
+
+=head2 API REFERENCE
+
+The C<CPANPLUS> API is meant to let you programmatically 
+interact with the C<CPAN> mirrors. The documentation in
+L<CPANPLUS::Backend> shows you how to create an object
+capable of interacting with those mirrors, letting you
+create & retrieve module objects.
+L<CPANPLUS::Module> shows you how you can use these module
+objects to perform actions like installing and testing. 
+
+The default shell, documented in L<CPANPLUS::Shell::Default>
+is also scriptable. You can use its API to dispatch calls
+from your script to the CPANPLUS Shell.
+
+=cut
+
+=head1 COMMANDLINE TOOLS
+
+=head2 STARTING AN INTERACTIVE SHELL
+
+You can start an interactive shell by running either of 
+the two following commands:
+
+    $ cpanp
+
+    $ perl -MCPANPLUS -eshell
+
+All commans available are listed in the interactive shells
+help menu. See C<cpanp -h> or L<CPANPLUS::Shell::Default> 
+for instructions on using the default shell.  
+    
+=head2 CHOOSE A SHELL
+
+By running C<cpanp> without arguments, you will start up
+the shell specified in your config, which defaults to 
+L<CPANPLUS::Shell::Default>. There are more shells available.
+C<CPANPLUS> itself ships with an emulation shell called 
+L<CPANPLUS::Shell::Classic> that looks and feels just like 
+the old C<CPAN.pm> shell.
+
+You can start this shell by typing:
+
+    $ perl -MCPANPLUS -e'shell Classic'
+    
+Even more shells may be available from C<CPAN>.    
+
+Note that if you have changed your default shell in your
+configuration, that shell will be used instead. If for 
+some reason there was an error with your specified shell, 
+you will be given the default shell.
+
+=head2 BUILDING PACKAGES
+
+C<cpan2dist> is a commandline tool to convert any distribution 
+from C<CPAN> into a package in the format of your choice, like
+for example C<.deb> or C<FreeBSD ports>. 
+
+See C<cpan2dist -h> for details.
+    
+    
+=head1 FUNCTIONS
+
+For quick access to common commands, you may use this module,
+C<CPANPLUS> rather than the full programmatic API situated in
+C<CPANPLUS::Backend>. This module offers the following functions:
+
+=head2 $bool = install( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
+
+This function requires the full name of the module, which is case
+sensitive.  The module name can also be provided as a fully
+qualified file name, beginning with a I</>, relative to
+the /authors/id directory on a CPAN mirror.
+
+It will download, extract and install the module.
+
+=head2 $where = fetch( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
+
+Like install, fetch needs the full name of a module or the fully
+qualified file name, and is case sensitive.
+
+It will download the specified module to the current directory.
+
+=head2 $where = get( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
+
+Get is provided as an alias for fetch for compatibility with
+CPAN.pm.
+
+=head2 shell()
+
+Shell starts the default CPAN shell.  You can also start the shell
+by using the C<cpanp> command, which will be installed in your
+perl bin.
+
+=head1 FAQ
+
+For frequently asked questions and answers, please consult the
+C<CPANPLUS::FAQ> manual.
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c) 
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it 
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Shell::Default>, L<CPANPLUS::FAQ>, L<CPANPLUS::Backend>, L<CPANPLUS::Module>, L<cpanp>, L<cpan2dist>
+
+=head1 CONTACT INFORMATION
+
+=over 4
+
+=item * Bug reporting:
+I<bug-cpanplus@rt.cpan.org>
+
+=item * Questions & suggestions:
+I<cpanplus-devel@lists.sourceforge.net>
+
+=back
+
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/CPANPLUS/Backend.pm b/lib/CPANPLUS/Backend.pm
new file mode 100644 (file)
index 0000000..50b13c4
--- /dev/null
@@ -0,0 +1,1061 @@
+package CPANPLUS::Backend;
+
+use strict;
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Configure;
+use CPANPLUS::Internals;
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Module;
+use CPANPLUS::Module::Author;
+use CPANPLUS::Backend::RV;
+
+use FileHandle;
+use File::Spec                  ();
+use File::Spec::Unix            ();
+use Params::Check               qw[check];
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+
+$Params::Check::VERBOSE = 1;
+
+use vars qw[@ISA $VERSION];
+
+@ISA     = qw[CPANPLUS::Internals];
+$VERSION = $CPANPLUS::Internals::VERSION;
+
+### mark that we're running under CPANPLUS to spawned processes
+$ENV{'PERL5_CPANPLUS_IS_RUNNING'} = $$;
+
+### XXX version.pm MAY format this version, if it's in use... :(
+### so for consistency, just call ->VERSION ourselves as well.
+$ENV{'PERL5_CPANPLUS_IS_VERSION'} = __PACKAGE__->VERSION;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Backend
+
+=head1 SYNOPSIS
+
+    my $cb      = CPANPLUS::Backend->new( );
+    my $conf    = $cb->configure_object;
+
+    my $author  = $cb->author_tree('KANE');
+    my $mod     = $cb->module_tree('Some::Module');
+    my $mod     = $cb->parse_module( module => 'Some::Module' );
+
+    my @objs    = $cb->search(  type    => TYPE,
+                                allow   => [...] );
+
+    $cb->flush('all');
+    $cb->reload_indices;
+    $cb->local_mirror;
+
+
+=head1 DESCRIPTION
+
+This module provides the programmer's interface to the C<CPANPLUS>
+libraries.
+
+=head1 ENVIRONMENT
+
+When C<CPANPLUS::Backend> is loaded, which is necessary for just
+about every <CPANPLUS> operation, the environment variable
+C<PERL5_CPANPLUS_IS_RUNNING> is set to the current process id.
+
+Additionally, the environment variable C<PERL5_CPANPLUS_IS_VERSION> 
+will be set to the version of C<CPANPLUS::Backend>.
+
+This information might be useful somehow to spawned processes.
+
+=head1 METHODS
+
+=head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] )
+
+This method returns a new C<CPANPLUS::Backend> object.
+This also initialises the config corresponding to this object.
+You have two choices in this:
+
+=over 4
+
+=item Provide a valid C<CPANPLUS::Configure> object
+
+This will be used verbatim.
+
+=item No arguments
+
+Your default config will be loaded and used.
+
+=back
+
+New will return a C<CPANPLUS::Backend> object on success and die on
+failure.
+
+=cut
+
+sub new {
+    my $class   = shift;
+    my $conf;
+
+    if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) {
+        $conf = shift;
+    } else {
+        $conf = CPANPLUS::Configure->new() or return;
+    }
+
+    my $self = $class->SUPER::_init( _conf => $conf );
+
+    return $self;
+}
+
+=pod
+
+=head2 $href = $cb->module_tree( [@modules_names_list] )
+
+Returns a reference to the CPANPLUS module tree.
+
+If you give it any arguments, they will be treated as module names
+and C<module_tree> will try to look up these module names and
+return the corresponding module objects instead.
+
+See L<CPANPLUS::Module> for the operations you can perform on a
+module object.
+
+=cut
+
+sub module_tree {
+    my $self    = shift;
+    my $modtree = $self->_module_tree;
+
+    if( @_ ) {
+        my @rv;
+        for my $name ( grep { defined } @_) {
+            push @rv, $modtree->{$name} || '';
+        }
+        return @rv == 1 ? $rv[0] : @rv;
+    } else {
+        return $modtree;
+    }
+}
+
+=pod
+
+=head2 $href = $cb->author_tree( [@author_names_list] )
+
+Returns a reference to the CPANPLUS author tree.
+
+If you give it any arguments, they will be treated as author names
+and C<author_tree> will try to look up these author names and
+return the corresponding author objects instead.
+
+See L<CPANPLUS::Module::Author> for the operations you can perform on
+an author object.
+
+=cut
+
+sub author_tree {
+    my $self        = shift;
+    my $authtree    = $self->_author_tree;
+
+    if( @_ ) {
+        my @rv;
+        for my $name (@_) {
+            push @rv, $authtree->{$name} || '';
+        }
+        return @rv == 1 ? $rv[0] : @rv;
+    } else {
+        return $authtree;
+    }
+}
+
+=pod
+
+=head2 $conf = $cb->configure_object ()
+
+Returns a copy of the C<CPANPLUS::Configure> object.
+
+See L<CPANPLUS::Configure> for operations you can perform on a
+configure object.
+
+=cut
+
+sub configure_object { return shift->_conf() };
+
+=head2 $su = $cb->selfupdate_object;
+
+Returns a copy of the C<CPANPLUS::Selfupdate> object.
+
+See the L<CPANPLUS::Selfupdate> manpage for the operations
+you can perform on the selfupdate object.
+
+=cut
+
+sub selfupdate_object { return shift->_selfupdate() };
+
+=pod
+
+=head2 @mods = $cb->search( type => TYPE, allow => AREF, [data => AREF, verbose => BOOL] )
+
+C<search> enables you to search for either module or author objects,
+based on their data. The C<type> you can specify is any of the
+accessors specified in C<CPANPLUS::Module::Author> or
+C<CPANPLUS::Module>. C<search> will determine by the C<type> you
+specified whether to search by author object or module object.
+
+You have to specify an array reference of regular expressions or
+strings to match against. The rules used for this array ref are the
+same as in C<Params::Check>, so read that manpage for details.
+
+The search is an C<or> search, meaning that if C<any> of the criteria
+match, the search is considered to be successful.
+
+You can specify the result of a previous search as C<data> to limit
+the new search to these module or author objects, rather than the
+entire module or author tree.  This is how you do C<and> searches.
+
+Returns a list of module or author objects on success and false
+on failure.
+
+See L<CPANPLUS::Module> for the operations you can perform on a
+module object.
+See L<CPANPLUS::Module::Author> for the operations you can perform on
+an author object.
+
+=cut
+
+sub search {
+    my $self = shift;
+    my $conf = $self->configure_object;
+    my %hash = @_;
+
+    local $Params::Check::ALLOW_UNKNOWN = 1;
+
+    my ($data,$type);
+    my $tmpl = {
+        type    => { required => 1, allow => [CPANPLUS::Module->accessors(),
+                        CPANPLUS::Module::Author->accessors()], store => \$type },
+        allow   => { required => 1, default => [ ], strict_type => 1 },
+    };
+
+    my $args = check( $tmpl, \%hash ) or return;
+
+    ### figure out whether it was an author or a module search
+    ### when ambiguous, it'll be an author search.
+    my $aref;
+    if( grep { $type eq $_ } CPANPLUS::Module::Author->accessors() ) {
+        $aref = $self->_search_author_tree( %$args );
+    } else {
+        $aref = $self->_search_module_tree( %$args );
+    }
+
+    return @$aref if $aref;
+    return;
+}
+
+=pod
+
+=head2 $backend_rv = $cb->fetch( modules => \@mods )
+
+Fetches a list of modules. C<@mods> can be a list of distribution
+names, module names or module objects--basically anything that
+L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=head2 $backend_rv = $cb->extract( modules => \@mods )
+
+Extracts a list of modules. C<@mods> can be a list of distribution
+names, module names or module objects--basically anything that
+L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=head2 $backend_rv = $cb->install( modules => \@mods )
+
+Installs a list of modules. C<@mods> can be a list of distribution
+names, module names or module objects--basically anything that
+L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=head2 $backend_rv = $cb->readme( modules => \@mods )
+
+Fetches the readme for a list of modules. C<@mods> can be a list of
+distribution names, module names or module objects--basically
+anything that L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=head2 $backend_rv = $cb->files( modules => \@mods )
+
+Returns a list of files used by these modules if they are installed.
+C<@mods> can be a list of distribution names, module names or module
+objects--basically anything that L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=head2 $backend_rv = $cb->distributions( modules => \@mods )
+
+Returns a list of module objects representing all releases for this
+module on success.
+C<@mods> can be a list of distribution names, module names or module
+objects, basically anything that L<parse_module> can understand.
+
+See the equivalent method in C<CPANPLUS::Module> for details on
+other options you can pass.
+
+Since this is a multi-module method call, the return value is
+implemented as a C<CPANPLUS::Backend::RV> object. Please consult
+that module's documentation on how to interpret the return value.
+
+=cut
+
+### XXX add direcotry_tree, packlist etc? or maybe remove files? ###
+for my $func (qw[fetch extract install readme files distributions]) {
+    no strict 'refs';
+
+    *$func = sub {
+        my $self = shift;
+        my $conf = $self->configure_object;
+        my %hash = @_;
+
+        local $Params::Check::NO_DUPLICATES = 1;
+        local $Params::Check::ALLOW_UNKNOWN = 1;
+
+        my ($mods);
+        my $tmpl = {
+            modules     => { default  => [],    strict_type => 1,
+                             required => 1,     store => \$mods },
+        };
+
+        my $args = check( $tmpl, \%hash ) or return;
+
+        ### make them all into module objects ###
+        my %mods = map {$_ => $self->parse_module(module => $_) || ''} @$mods;
+
+        my $flag; my $href;
+        while( my($name,$obj) = each %mods ) {
+            $href->{$name} = IS_MODOBJ->( mod => $obj )
+                                ? $obj->$func( %$args )
+                                : undef;
+
+            $flag++ unless $href->{$name};
+        }
+
+        return CPANPLUS::Backend::RV->new(
+                    function    => $func,
+                    ok          => !$flag,
+                    rv          => $href,
+                    args        => \%hash,
+                );
+    }
+}
+
+=pod
+
+=head2 $mod_obj = $cb->parse_module( module => $modname|$distname|$modobj )
+
+C<parse_module> tries to find a C<CPANPLUS::Module> object that
+matches your query. Here's a list of examples you could give to
+C<parse_module>;
+
+=over 4
+
+=item Text::Bastardize
+
+=item Text-Bastardize
+
+=item Text-Bastardize-1.06
+
+=item AYRNIEU/Text-Bastardize
+
+=item AYRNIEU/Text-Bastardize-1.06
+
+=item AYRNIEU/Text-Bastardize-1.06.tar.gz
+
+=item http://example.com/Text-Bastardize-1.06.tar.gz
+
+=item file:///tmp/Text-Bastardize-1.06.tar.gz
+
+=back
+
+These items would all come up with a C<CPANPLUS::Module> object for
+C<Text::Bastardize>. The ones marked explicitly as being version 1.06
+would give back a C<CPANPLUS::Module> object of that version.
+Even if the version on CPAN is currently higher.
+
+If C<parse_module> is unable to actually find the module you are looking
+for in its module tree, but you supplied it with an author, module
+and version part in a distribution name or URI, it will create a fake
+C<CPANPLUS::Module> object for you, that you can use just like the
+real thing.
+
+See L<CPANPLUS::Module> for the operations you can perform on a
+module object.
+
+If even this fancy guessing doesn't enable C<parse_module> to create
+a fake module object for you to use, it will warn about an error and
+return false.
+
+=cut
+
+sub parse_module {
+    my $self = shift;
+    my $conf = $self->configure_object;
+    my %hash = @_;
+
+    my $mod;
+    my $tmpl = {
+        module  => { required => 1, store => \$mod },
+    };
+
+    my $args = check( $tmpl, \%hash ) or return;
+
+    return $mod if IS_MODOBJ->( module => $mod );
+
+    ### ok, so it's not a module object, but a ref nonetheless?
+    ### what are you smoking?
+    if( ref $mod ) {
+        error(loc("Can not parse module string from reference '%1'", $mod ));
+        return;
+    }
+    
+    ### check only for allowed characters in a module name
+    unless( $mod =~ /[^\w:]/ ) {
+
+        ### perhaps we can find it in the module tree?
+        my $maybe = $self->module_tree($mod);
+        return $maybe if IS_MODOBJ->( module => $maybe );
+    }
+
+    ### ok, so it looks like a distribution then?
+    my @parts   = split '/', $mod;
+    my $dist    = pop @parts;
+
+    ### ah, it's a URL
+    if( $mod =~ m|\w+://.+| ) {
+        my $modobj = CPANPLUS::Module::Fake->new(
+                        module  => $dist,
+                        version => 0,
+                        package => $dist,
+                        path    => File::Spec::Unix->catdir(
+                                        $conf->_get_mirror('base'),
+                                        UNKNOWN_DL_LOCATION ),
+                        author  => CPANPLUS::Module::Author::Fake->new
+                    );
+        
+        ### set the fetch_from accessor so we know to by pass the
+        ### usual mirrors
+        $modobj->status->_fetch_from( $mod );
+        
+        return $modobj;      
+    }
+    
+    ### perhaps we can find it's a third party module?
+    {   my $modobj = CPANPLUS::Module::Fake->new(
+                        module  => $mod,
+                        version => 0,
+                        package => $dist,
+                        path    => File::Spec::Unix->catdir(
+                                        $conf->_get_mirror('base'),
+                                        UNKNOWN_DL_LOCATION ),
+                        author  => CPANPLUS::Module::Author::Fake->new
+                    );
+        if( $modobj->is_third_party ) {
+            my $info = $modobj->third_party_information;
+            
+            $modobj->author->author( $info->{author}     );
+            $modobj->author->email(  $info->{author_url} );
+            $modobj->description(    $info->{url} );
+
+            return $modobj;
+        }
+    }
+
+    unless( $dist ) {
+        error( loc("%1 is not a proper distribution name!", $mod) );
+        return;
+    }
+    
+    ### there's wonky uris out there, like this:
+    ### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091
+    ### compensate for that
+    my $author;
+    ### you probably have an A/AB/ABC/....../Dist.tgz type uri
+    if( (defined $parts[0] and length $parts[0] == 1) and 
+        (defined $parts[1] and length $parts[1] == 2) and
+        $parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i
+    ) {   
+        splice @parts, 0, 2;    # remove the first 2 entries from the list
+        $author = shift @parts; # this is the actual author name then    
+
+    ### we''ll assume a ABC/..../Dist.tgz
+    } else {
+        $author = shift @parts || '';
+    }
+    
+    my($pkg, $version, $ext) = 
+        $self->_split_package_string( package => $dist );
+    
+    ### translate a distribution into a module name ###
+    my $guess = $pkg; 
+    $guess =~ s/-/::/g if $guess; 
+
+    my $maybe = $self->module_tree( $guess );
+    if( IS_MODOBJ->( module => $maybe ) ) {
+
+        ### maybe you asked for a package instead
+        if ( $maybe->package eq $mod ) {
+            return $maybe;
+
+        ### perhaps an outdated version instead?
+        } elsif ( $version ) {
+            my $auth_obj; my $path;
+
+            ### did you give us an author part? ###
+            if( $author ) {
+                $auth_obj   = CPANPLUS::Module::Author::Fake->new(
+                                    _id     => $maybe->_id,
+                                    cpanid  => uc $author,
+                                    author  => uc $author,
+                                );
+                $path       = File::Spec::Unix->catdir(
+                                    $conf->_get_mirror('base'),
+                                    substr(uc $author, 0, 1),
+                                    substr(uc $author, 0, 2),
+                                    uc $author,
+                                    @parts,     #possible sub dirs
+                                );
+            } else {
+                $auth_obj   = $maybe->author;
+                $path       = $maybe->path;
+            }        
+        
+            if( $maybe->package_name eq $pkg ) {
+    
+                my $modobj = CPANPLUS::Module::Fake->new(
+                    module  => $maybe->module,
+                    version => $version,
+                    package => $pkg . '-' . $version . '.' .
+                                    $maybe->package_extension,
+                    path    => $path,
+                    author  => $auth_obj,
+                    _id     => $maybe->_id
+                );
+                return $modobj;
+
+            ### you asked for a specific version?
+            ### assume our $maybe is the one you wanted,
+            ### and fix up the version.. 
+            } else {
+    
+                my $modobj = $maybe->clone;
+                $modobj->version( $version );
+                $modobj->package( 
+                        $maybe->package_name .'-'. 
+                        $version .'.'. 
+                        $maybe->package_extension 
+                );
+                
+                ### you wanted a specific author, but it's not the one
+                ### from the module tree? we'll fix it up
+                if( $author and $author ne $modobj->author->cpanid ) {
+                    $modobj->author( $auth_obj );
+                    $modobj->path( $path );
+                }
+                
+                return $modobj;
+            }
+        
+        ### you didn't care about a version, so just return the object then
+        } elsif ( !$version ) {
+            return $maybe;
+        }
+
+    ### ok, so we can't find it, and it's not an outdated dist either
+    ### perhaps we can fake one based on the author name and so on
+    } elsif ( $author and $version ) {
+
+        ### be extra friendly and pad the .tar.gz suffix where needed
+        ### it's just a guess of course, but most dists are .tar.gz
+        $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
+
+        ### XXX duplication from above for generating author obj + path...
+        my $modobj = CPANPLUS::Module::Fake->new(
+            module  => $guess,
+            version => $version,
+            package => $dist,
+            author  => CPANPLUS::Module::Author::Fake->new(
+                            author  => uc $author,
+                            cpanid  => uc $author,
+                            _id     => $self->_id,
+                        ),
+            path    => File::Spec::Unix->catdir(
+                            $conf->_get_mirror('base'),
+                            substr(uc $author, 0, 1),
+                            substr(uc $author, 0, 2),
+                            uc $author,
+                            @parts,         #possible subdirs
+                        ),
+            _id     => $self->_id,
+        );
+
+        return $modobj;
+
+    ### face it, we have /no/ idea what he or she wants...
+    ### let's start putting the blame somewhere
+    } else {
+
+        unless( $author ) {
+            error( loc( "'%1' does not contain an author part", $mod ) );
+        }
+
+        error( loc( "Cannot find '%1' in the module tree", $mod ) );
+    }
+
+    return;
+}
+
+=pod
+
+=head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] );
+
+This method reloads the source files.
+
+If C<update_source> is set to true, this will fetch new source files
+from your CPAN mirror. Otherwise, C<reload_indices> will do its
+usual cache checking and only update them if they are out of date.
+
+By default, C<update_source> will be false.
+
+The verbose setting defaults to what you have specified in your
+config file.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub reload_indices {
+    my $self    = shift;
+    my %hash    = @_;
+    my $conf    = $self->configure_object;
+
+    my $tmpl = {
+        update_source   => { default    => 0, allow => [qr/^\d$/] },
+        verbose         => { default    => $conf->get_conf('verbose') },
+    };
+
+    my $args = check( $tmpl, \%hash ) or return;
+
+    ### make a call to the internal _module_tree, so it triggers cache
+    ### file age
+    my $uptodate = $self->_check_trees( %$args );
+
+
+    return 1 if $self->_build_trees(
+                                uptodate    => $uptodate,
+                                use_stored  => 0,
+                                verbose     => $conf->get_conf('verbose'),
+                            );
+
+    error( loc( "Error rebuilding source trees!" ) );
+
+    return;
+}
+
+=pod
+
+=head2 $bool = $cb->flush(CACHE_NAME)
+
+This method allows flushing of caches.
+There are several things which can be flushed:
+
+=over 4
+
+=item * C<methods>
+
+The return status of methods which have been attempted, such as
+different ways of fetching files.  It is recommended that automatic
+flushing be used instead.
+
+=item * C<hosts>
+
+The return status of URIs which have been attempted, such as
+different hosts of fetching files.  It is recommended that automatic
+flushing be used instead.
+
+=item * C<modules>
+
+Information about modules such as prerequisites and whether
+installation succeeded, failed, or was not attempted.
+
+=item * C<lib>
+
+This resets PERL5LIB, which is changed to ensure that while installing
+modules they are in our @INC.
+
+=item * C<load>
+
+This resets the cache of modules we've attempted to load, but failed.
+This enables you to load them again after a failed load, if they 
+somehow have become available.
+
+=item * C<all>
+
+Flush all of the aforementioned caches.
+
+=back
+
+Returns true on success and false on failure.
+
+=cut
+
+sub flush {
+    my $self = shift;
+    my $type = shift or return;
+
+    my $cache = {
+        methods => [ qw( methods load ) ],
+        hosts   => [ qw( hosts ) ],
+        modules => [ qw( modules lib) ],
+        lib     => [ qw( lib ) ],
+        load    => [ qw( load ) ],
+        all     => [ qw( hosts lib modules methods load ) ],
+    };
+
+    my $aref = $cache->{$type}
+                    or (
+                        error( loc("No such cache '%1'", $type) ),
+                        return
+                    );
+
+    return $self->_flush( list => $aref );
+}
+
+=pod
+
+=head2 @mods = $cb->installed()
+
+Returns a list of module objects of all your installed modules.
+If an error occurs, it will return false.
+
+See L<CPANPLUS::Module> for the operations you can perform on a
+module object.
+
+=cut
+
+sub installed {
+    my $self = shift;
+    my $aref = $self->_all_installed;
+
+    return @$aref if $aref;
+    return;
+}
+
+=pod
+
+=head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] )
+
+Creates a local mirror of CPAN, of only the most recent sources in a
+location you specify. If you set this location equal to a custom host
+in your C<CPANPLUS::Config> you can use your local mirror to install
+from.
+
+It takes the following arguments:
+
+=over 4
+
+=item path
+
+The location where to create the local mirror.
+
+=item index_files
+
+Enable/disable fetching of index files. This is ok if you don't plan
+to use the local mirror as your primary sites, or if you'd like
+up-to-date index files be fetched from elsewhere.
+
+Defaults to true.
+
+=item force
+
+Forces refetching of packages, even if they are there already.
+
+Defaults to whatever setting you have in your C<CPANPLUS::Config>.
+
+=item verbose
+
+Prints more messages about what its doing.
+
+Defaults to whatever setting you have in your C<CPANPLUS::Config>.
+
+=back
+
+Returns true on success and false on error.
+
+=cut
+
+sub local_mirror {
+    my $self = shift;
+    my $conf = $self->configure_object;
+    my %hash = @_;
+
+    my($path, $index, $force, $verbose);
+    my $tmpl = {
+        path        => { default => $conf->get_conf('base'),
+                            store => \$path },
+        index_files => { default => 1, store => \$index },
+        force       => { default => $conf->get_conf('force'),
+                            store => \$force },
+        verbose     => { default => $conf->get_conf('verbose'),
+                            store => \$verbose },
+    };
+
+    check( $tmpl, \%hash ) or return;
+
+    unless( -d $path ) {
+        $self->_mkdir( dir => $path )
+                or( error( loc( "Could not create '%1', giving up", $path ) ),
+                    return
+                );
+    } elsif ( ! -w _ ) {
+        error( loc( "Could not write to '%1', giving up", $path ) );
+        return;
+    }
+
+    my $flag;
+    AUTHOR: {
+    for my $auth (  sort { $a->cpanid cmp $b->cpanid }
+                    values %{$self->author_tree}
+    ) {
+
+        MODULE: {
+        my $i;
+        for my $mod ( $auth->modules ) {
+            my $fetchdir = File::Spec->catdir( $path, $mod->path );
+
+            my %opts = (
+                verbose     => $verbose,
+                force       => $force,
+                fetchdir    => $fetchdir,
+            );
+
+            ### only do this the for the first module ###
+            unless( $i++ ) {
+                $mod->_get_checksums_file(
+                            %opts
+                        ) or (
+                            error( loc( "Could not fetch %1 file, " .
+                                        "skipping author '%2'",
+                                        CHECKSUMS, $auth->cpanid ) ),
+                            $flag++, next AUTHOR
+                        );
+            }
+
+            $mod->fetch( %opts )
+                    or( error( loc( "Could not fetch '%1'", $mod->module ) ),
+                        $flag++, next MODULE
+                    );
+        } }
+    } }
+
+    if( $index ) {
+        for my $name (qw[auth dslip mod]) {
+            $self->_update_source(
+                        name    => $name,
+                        verbose => $verbose,
+                        path    => $path,
+                    ) or ( $flag++, next );
+        }
+    }
+
+    return !$flag;
+}
+
+=pod
+
+=head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL])
+
+Writes out a snapshot of your current installation in C<CPAN> bundle
+style. This can then be used to install the same modules for a
+different or on a different machine.
+
+It will, by default, write to an 'autobundle' directory under your
+cpanplus homedirectory, but you can override that by supplying a
+C<path> argument.
+
+It will return the location of the output file on success and false on
+failure.
+
+=cut
+
+sub autobundle {
+    my $self = shift;
+    my $conf = $self->configure_object;
+    my %hash = @_;
+
+    my($path,$force,$verbose);
+    my $tmpl = {
+        force   => { default => $conf->get_conf('force'), store => \$force },
+        verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+        path    => { default => File::Spec->catdir(
+                                        $conf->get_conf('base'),
+                                        $self->_perl_version( perl => $^X ),
+                                        $conf->_get_build('distdir'),
+                                        $conf->_get_build('autobundle') ),
+                    store => \$path },
+    };
+
+    check($tmpl, \%hash) or return;
+
+    unless( -d $path ) {
+        $self->_mkdir( dir => $path )
+                or( error(loc("Could not create directory '%1'", $path ) ),
+                    return
+                );
+    }
+
+    my $name; my $file;
+    {   ### default filename for the bundle ###
+        my($year,$month,$day) = (localtime)[5,4,3];
+        $year += 1900; $month++;
+
+        my $ext = 0;
+
+        my $prefix  = $conf->_get_build('autobundle_prefix');
+        my $format  = "${prefix}_%04d_%02d_%02d_%02d";
+
+        BLOCK: {
+            $name = sprintf( $format, $year, $month, $day, $ext);
+
+            $file = File::Spec->catfile( $path, $name . '.pm' );
+
+            -f $file ? ++$ext && redo BLOCK : last BLOCK;
+        }
+    }
+    my $fh;
+    unless( $fh = FileHandle->new( ">$file" ) ) {
+        error( loc( "Could not open '%1' for writing: %2", $file, $! ) );
+        return;
+    }
+
+    my $string = join "\n\n",
+                    map {
+                        join ' ',
+                            $_->module,
+                            ($_->installed_version(verbose => 0) || 'undef')
+                    } sort {
+                        $a->module cmp $b->module
+                    }  $self->installed;
+
+    my $now     = scalar localtime;
+    my $head    = '=head1';
+    my $pkg     = __PACKAGE__;
+    my $version = $self->VERSION;
+    my $perl_v  = join '', `$^X -V`;
+
+    print $fh <<EOF;
+package $name
+
+\$VERSION = '0.01';
+
+1;
+
+__END__
+
+$head NAME
+
+$name - Snapshot of your installation at $now
+
+$head SYNOPSIS
+
+perl -MCPANPLUS -e "install $name"
+
+$head CONTENTS
+
+$string
+
+$head CONFIGURATION
+
+$perl_v
+
+$head AUTHOR
+
+This bundle has been generated autotomatically by
+    $pkg $version
+
+EOF
+
+    close $fh;
+
+    return $file;
+}
+
+1;
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c) 
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it 
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+__END__
+
+todo:
+sub dist {          # not sure about this one -- probably already done
+                      enough in Module.pm
+sub reports {       # in Module.pm, wrapper here
+
+
diff --git a/lib/CPANPLUS/Backend/RV.pm b/lib/CPANPLUS/Backend/RV.pm
new file mode 100644 (file)
index 0000000..9edbe04
--- /dev/null
@@ -0,0 +1,144 @@
+package CPANPLUS::Backend::RV;
+
+use strict;
+use vars qw[$STRUCT];
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use IPC::Cmd                    qw[can_run run];
+use Params::Check               qw[check];
+
+use base 'Object::Accessor';
+
+local $Params::Check::VERBOSE = 1;
+
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Backend::RV
+
+=head1 SYNOPSIS
+
+    ### create a CPANPLUS::Backend::RV object
+    $backend_rv     = CPANPLUS::Backend::RV->new(
+                                ok          => $boolean,
+                                args        => $args,
+                                rv          => $return_value
+                                function    => $calling_function );
+
+    ### if you have a CPANPLUS::Backend::RV object
+    $passed_args    = $backend_rv->args;    # args passed to function
+    $ok             = $backend_rv->ok;      # boolean indication overall
+                                            # result of the call
+    $function       = $backend_rv->fucntion # name of the calling
+                                            # function
+    $rv             = $backend_rv->rv       # the actual return value
+                                            # of the calling function
+
+=head1 DESCRIPTION
+
+This module provides return value objects for multi-module
+calls to CPANPLUS::Backend. In boolean context, it returns the status
+of the overall result (ie, the same as the C<ok> method would).
+
+=head1 METHODS
+
+=head2 new( ok => BOOL, args => DATA, rv => DATA, [function => $method_name] )
+
+Creates a new CPANPLUS::Backend::RV object from the data provided.
+This method should only be called by CPANPLUS::Backend functions.
+The accessors may be used by users inspecting an RV object.
+
+All the argument names can be used as accessors later to retrieve the
+data.
+
+Arguments:
+
+=over 4
+
+=item ok
+
+Boolean indicating overall success
+
+=item args
+
+The arguments provided to the function that returned this rv object.
+Useful to inspect later to see what was actually passed to the function
+in case of an error.
+
+=item rv
+
+An arbitrary data structure that has the detailed return values of each
+of your multi-module calls.
+
+=item function
+
+The name of the function that created this rv object.
+Can be explicitly passed. If not, C<new()> will try to deduce the name
+from C<caller()> information.
+
+=back
+
+=cut
+
+sub new {
+    my $class   = shift;
+    my %hash    = @_;
+
+    my $tmpl = {
+        ok          => { required => 1, allow => BOOLEANS },
+        args        => { required => 1 },
+        rv          => { required => 1 },
+        function    => { default => CALLING_FUNCTION->() },
+    };
+
+    my $args    = check( $tmpl, \%hash ) or return;
+    my $self    = bless {}, $class;
+
+#    $self->mk_accessors( qw[ok args function rv] );
+    $self->mk_accessors( keys %$tmpl );
+
+    ### set the values passed in the struct ###
+    while( my($key,$val) = each %$args ) {
+        $self->$key( $val );
+    }
+
+    return $self;
+}
+
+sub _ok { return shift->ok }
+#sub _stringify  { Carp::carp( "stringifying!" ); overload::StrVal( shift ) }
+
+### make it easier to check if($rv) { foo() }
+### this allows people to not have to explicitly say
+### if( $rv->ok ) { foo() }
+### XXX add an explicit stringify, so it doesn't fall back to "bool"? :(
+use overload bool       => \&_ok, 
+#             '""'       => \&_stringify,
+             fallback   => 1;
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c) 
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it 
+under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/lib/CPANPLUS/Config.pm b/lib/CPANPLUS/Config.pm
new file mode 100644 (file)
index 0000000..2516559
--- /dev/null
@@ -0,0 +1,264 @@
+package CPANPLUS::Config;
+
+use strict;
+use warnings;
+
+use base 'Object::Accessor';
+
+use base 'CPANPLUS::Internals::Utils';
+
+use Config;
+use File::Spec;
+use Module::Load;
+use CPANPLUS;
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use File::Basename              qw[dirname];
+use IPC::Cmd                    qw[can_run];
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+use Module::Load::Conditional   qw[check_install];
+
+my $Conf = {
+    '_fetch' => {
+        'blacklist' => [ 'ftp' ],
+    },
+    'conf' => {
+        ### default host list
+        'hosts' => [
+            {
+                'scheme' => 'ftp',
+                'path' => '/pub/CPAN/',
+                'host' => 'ftp.cpan.org'
+            },
+            {
+                'scheme' => 'http',
+                'path' => '/',
+                'host' => 'www.cpan.org'
+            },
+            {
+                'scheme' => 'ftp',
+                'path' => '/pub/CPAN/',
+                'host' => 'ftp.nl.uu.net'
+            },
+            {
+                'scheme' => 'ftp',
+                'path' => '/pub/CPAN/',
+                'host' => 'cpan.valueclick.com'
+            },
+            {
+                'scheme' => 'ftp',
+                'path' => '/pub/languages/perl/CPAN/',
+                'host' => 'ftp.funet.fi'
+            }
+        ],
+        'allow_build_interactivity' => 1,
+        'base'                      => File::Spec->catdir(
+                                        __PACKAGE__->_home_dir, DOT_CPANPLUS ),
+        'buildflags'                => '',
+        'cpantest'                  => 0,
+        'cpantest_mx'               => '',
+        'debug'                     => 0,
+        'dist_type'                 => '',
+        'email'                     => DEFAULT_EMAIL,
+        'extractdir'                => '',
+        'fetchdir'                  => '',
+        'flush'                     => 1,
+        'force'                     => 0,
+        'lib'                       => [],
+        'makeflags'                 => '',
+        'makemakerflags'            => '',
+        'md5'                       => ( 
+                            check_install( module => 'Digest::MD5' ) ? 1 : 0 ),
+        'no_update'                 => 0,
+        'passive'                   => 1,
+        ### if we dont have c::zlib, we'll need to use /bin/tar or we
+        ### can not extract any files. Good time to change the default
+        'prefer_bin'                => (eval {require Compress::Zlib; 1}?0:1),
+        'prefer_makefile'           => 1,
+        'prereqs'                   => PREREQ_ASK,
+        'shell'                     => 'CPANPLUS::Shell::Default',
+        'show_startup_tip'          => 1,
+        'signature'                 => ( (can_run( 'gpg' ) || 
+                            check_install( module => 'Crypt::OpenPGP' ))?1:0 ),
+        'skiptest'                  => 0,
+        'storable'                  => (
+                            check_install( module => 'Storable' )  ? 1 : 0 ),
+        'timeout'                   => 300,
+        'verbose'                   => $ENV{PERL5_CPANPLUS_VERBOSE} || 0,
+        'write_install_logs'        => 1,
+    },
+    ### Paths get stripped of whitespace on win32 in the constructor
+    ### sudo gets emptied if there's no need for it in the constructor
+    'program' => {
+        'editor'    => ( $ENV{'EDITOR'}  || $ENV{'VISUAL'} ||
+                         can_run('vi')   || can_run('pico')
+                       ),
+        'make'      => ( can_run($Config{'make'}) || can_run('make') ),
+        'pager'     => ( $ENV{'PAGER'} || can_run('less') || can_run('more') ),
+        ### no one uses this feature anyway, and it's only working for EU::MM
+        ### and not for module::build
+        #'perl'      => '',
+        'shell'     => ( $^O eq 'MSWin32' ? $ENV{COMSPEC} : $ENV{SHELL} ),
+        'sudo'      => ( $> # check for all install dirs!
+                            # installsiteman3dir is a 5.8'ism.. don't check
+                            # it on 5.6.x...
+                            ? ( -w $Config{'installsitelib'} &&
+                                ( defined $Config{'installsiteman3dir'} &&
+                                       -w $Config{'installsiteman3dir'}
+                                ) &&
+                                -w $Config{'installsitebin'} 
+                                    ? undef
+                                    : can_run('sudo') 
+                              )
+                            : can_run('sudo')
+                        ),
+        ### perlwrapper that allows us to turn on autoflushing                        
+        'perlwrapper'   => (    ### parallel to your cpanp/cpanp-boxed
+                                do { my $f = File::Spec->rel2abs(
+                                        File::Spec->catdir( 
+                                            dirname($0), 'cpanp-run-perl' 
+                                        )
+                                     );
+                                    -e $f ? $f : undef
+                                } ||
+                                
+                                ### parallel to your CPANPLUS.pm:
+                                ### $INC{cpanplus}/../bin/cpanp-run-perl
+                                do { my $f = File::Spec->rel2abs(
+                                        File::Spec->catdir( 
+                                            dirname( $INC{'CPANPLUS.pm'} ),
+                                            '..',   # lib dir
+                                            'bin',  # bin dir
+                                            'cpanp-run-perl' 
+                                        )
+                                     );
+                                    -e $f ? $f : undef
+                                } ||
+                                ### you installed CPANPLUS in a custom prefix,
+                                ### so go paralel to /that/. PREFIX=/tmp/cp
+                                ### would put cpanp-run-perl in /tmp/cp/bin and
+                                ### CPANPLUS.pm in
+                                ### /tmp/cp/lib/perl5/site_perl/5.8.8
+                                do { my $f = File::Spec->rel2abs(
+                                        File::Spec->catdir( 
+                                            dirname( $INC{'CPANPLUS.pm'} ),
+                                            '..', '..', '..', '..', # 4x updir
+                                            'bin',                  # bin dir
+                                            'cpanp-run-perl' 
+                                        )
+                                     );
+                                    -e $f ? $f : undef
+                                } ||
+
+                                ### in your path -- take this one last, the
+                                ### previous two assume extracted tarballs
+                                ### or user installs
+                                ### note that we don't use 'can_run' as it's
+                                ### not an executable, just a wrapper...
+                                do { my $rv;
+                                     for (split(/\Q$Config::Config{path_sep}\E/, 
+                                                $ENV{PATH}), File::Spec->curdir
+                                     ) {           
+                                        my $path = File::Spec->catfile(
+                                                    $_, 'cpanp-run-perl' );
+                                        if( -e $path ) {
+                                            $rv = $path;
+                                            last;
+                                        }     
+                                    }
+                                    
+                                    $rv || undef;
+                                } ||       
+
+                                ### XXX try to be a no-op instead then.. 
+                                ### cross your fingers...
+                                ### pass '-P' to perl: "run program through C 
+                                ### preprocessor before compilation"
+                                do { 
+                                    error(loc(
+                                        "Could not find the '%1' in your path".
+                                        "--this may be a problem.\n".
+                                        "Please locate this program and set ".
+                                        "your '%1' config entry to its path.\n".                
+                                        "Attempting to provide a reasonable ".
+                                        "fallback...",
+                                        'cpanp-run-perl', 'perlwrapper'
+                                     ));                                        
+                                    '-P'
+                                },   
+                        ),         
+    },
+
+    ### _source, _build and _mirror are supposed to be static
+    ### no changes should be needed unless pause/cpan changes
+    '_source' => {
+        'hosts'             => 'MIRRORED.BY',
+        'auth'              => '01mailrc.txt.gz',
+        'stored'            => 'sourcefiles',
+        'dslip'             => '03modlist.data.gz',
+        'update'            => '86400',
+        'mod'               => '02packages.details.txt.gz'
+    },
+    '_build' => {
+        'plugins'           => 'plugins',
+        'moddir'            => 'build',
+        'startdir'          => '',
+        'distdir'           => 'dist',
+        'autobundle'        => 'autobundle',
+        'autobundle_prefix' => 'Snapshot',
+        'autdir'            => 'authors',
+        'install_log_dir'   => 'install-logs',
+        'sanity_check'      => 1,
+    },
+    '_mirror' => {
+        'base'              => 'authors/id/',
+        'auth'              => 'authors/01mailrc.txt.gz',
+        'dslip'             => 'modules/03modlist.data.gz',
+        'mod'               => 'modules/02packages.details.txt.gz'
+    },
+};
+    
+sub new {
+    my $class   = shift;
+    my $obj     = $class->SUPER::new;
+
+    $obj->mk_accessors( keys %$Conf );
+
+    for my $acc ( keys %$Conf ) {
+        my $subobj = Object::Accessor->new;
+        $subobj->mk_accessors( keys %{$Conf->{$acc}} );
+
+        ### read in all the settings from the sub accessors;
+        for my $subacc ( $subobj->ls_accessors ) {
+            $subobj->$subacc( $Conf->{$acc}->{$subacc} );
+        }
+
+        ### now store it in the parent object
+        $obj->$acc( $subobj );
+    }
+    
+    $obj->_clean_up_paths;
+    
+    ### shut up IPC::Cmd warning about not findin IPC::Run on win32
+    $IPC::Cmd::WARN = 0;
+    
+    return $obj;
+}
+
+sub _clean_up_paths {
+    my $self = shift;
+
+    ### clean up paths if we are on win32
+    if( $^O eq 'MSWin32' ) {
+        for my $pgm ( $self->program->ls_accessors ) {
+            $self->program->$pgm(
+                Win32::GetShortPathName( $self->program->$pgm )
+            ) if $self->program->$pgm =~ /\s+/;      
+        }
+    }
+
+    return 1;
+}
+
+1;
diff --git a/lib/CPANPLUS/Configure.pm b/lib/CPANPLUS/Configure.pm
new file mode 100644 (file)
index 0000000..51d74ef
--- /dev/null
@@ -0,0 +1,601 @@
+package CPANPLUS::Configure;
+use strict;
+
+
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Error;
+use CPANPLUS::Config;
+
+use Log::Message;
+use Module::Load                qw[load];
+use Params::Check               qw[check];
+use File::Basename              qw[dirname];
+use Module::Loaded              ();
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+
+use vars                        qw[$AUTOLOAD $VERSION $MIN_CONFIG_VERSION];
+use base                        qw[CPANPLUS::Internals::Utils];
+
+local $Params::Check::VERBOSE = 1;
+
+### require, avoid circular use ###
+require CPANPLUS::Internals;
+$VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION;
+
+### can't use O::A as we're using our own AUTOLOAD to get to
+### the config options.
+for my $meth ( qw[conf]) {
+    no strict 'refs';
+    
+    *$meth = sub {
+        my $self = shift;
+        $self->{'_'.$meth} = $_[0] if @_;
+        return $self->{'_'.$meth};
+    }     
+}
+
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Configure
+
+=head1 SYNOPSIS
+
+    $conf   = CPANPLUS::Configure->new( );
+
+    $bool   = $conf->can_save;
+    $bool   = $conf->save( $where );
+
+    @opts   = $conf->options( $type );
+
+    $make       = $conf->get_program('make');
+    $verbose    = $conf->set_conf( verbose => 1 );
+
+=head1 DESCRIPTION
+
+This module deals with all the configuration issues for CPANPLUS.
+Users can use objects created by this module to alter the behaviour
+of CPANPLUS.
+
+Please refer to the C<CPANPLUS::Backend> documentation on how to
+obtain a C<CPANPLUS::Configure> object.
+
+=head1 METHODS
+
+=head2 $Configure = CPANPLUS::Configure->new( load_configs => BOOL )
+
+This method returns a new object. Normal users will never need to
+invoke the C<new> method, but instead retrieve the desired object via
+a method call on a C<CPANPLUS::Backend> object.
+
+The C<load_configs> parameter controls wether or not additional
+user configurations are to be loaded or not. Defaults to C<true>.
+
+=cut
+
+### store teh CPANPLUS::Config object in a closure, so we only
+### initialize it once.. otherwise, on a 2nd ->new, settings
+### from configs on top of this one will be reset
+{   my $Config;
+
+    sub new {
+        my $class   = shift;
+        my %hash    = @_;
+        
+        ### XXX pass on options to ->init() like rescan?
+        my ($load);
+        my $tmpl    = {
+            load_configs    => { default => 1, store => \$load },
+        };
+        
+        check( $tmpl, \%hash ) or (
+            warn Params::Check->last_error, return
+        );
+        
+        $Config     ||= CPANPLUS::Config->new;
+        my $self    = bless {}, $class;
+        $self->conf( $Config );
+    
+        ### you want us to load other configs?
+        ### these can override things in the default config
+        $self->init if $load;
+    
+        return $self;
+    }
+}
+
+=head2 $bool = $Configure->init( [rescan => BOOL])
+
+Initialize the configure with other config files than just
+the default 'CPANPLUS::Config'.
+
+Called from C<new()> to load user/system configurations
+
+If the C<rescan> option is provided, your disk will be
+examined again to see if there are new config files that
+could be read. Defaults to C<false>.
+
+Returns true on success, false on failure.
+
+=cut
+
+### move the Module::Pluggable detection to runtime, rather
+### than compile time, so that a simple 'require CPANPLUS'
+### doesn't start running over your filesystem for no good
+### reason. Make sure we only do the M::P call once though.
+### we use $loaded to mark it
+{   my $loaded;
+    my $warned;
+    sub init {
+        my $self    = shift;
+        my $obj     = $self->conf;
+        my %hash    = @_;
+        
+        my ($rescan);
+        my $tmpl    = {
+            rescan  => { default => 0, store => \$rescan },
+        };
+        
+        check( $tmpl, \%hash ) or (
+            warn Params::Check->last_error, return
+        );        
+        
+        ### warn if we find an old style config specified
+        ### via environment variables
+        {   my $env = ENV_CPANPLUS_CONFIG;
+            if( $ENV{$env} and not $warned ) {
+                $warned++;
+                error(loc("Specifying a config file in your environment " .
+                          "using %1 is obsolete.\nPlease follow the ".
+                          "directions outlined in %2 or use the '%3' command\n".
+                          "in the default shell to use custom config files.",
+                          $env, "CPANPLUS::Configure->save", 's save'));
+            }
+        }            
+        
+        ### make sure that the homedir is included now
+        local @INC = ( CONFIG_USER_LIB_DIR->(), @INC );
+        
+        ### only set it up once
+        if( !$loaded++ or $rescan ) {   
+            ### find plugins & extra configs
+            ### check $home/.cpanplus/lib as well
+            require Module::Pluggable;
+            
+            Module::Pluggable->import(
+                search_path => ['CPANPLUS::Config'],
+                search_dirs => [ CONFIG_USER_LIB_DIR ],
+                except      => qr/::SUPER$/,
+                sub_name    => 'configs'
+            );
+        }
+        
+        
+        ### do system config, user config, rest.. in that order
+        ### apparently, on a 2nd invocation of -->configs, a
+        ### ::ISA::CACHE package can appear.. that's bad...
+        my %confs = map  { $_ => $_ } 
+                    grep { $_ !~ /::ISA::/ } __PACKAGE__->configs;
+        my @confs = grep { defined } 
+                    map  { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER;
+        push @confs, sort keys %confs;                    
+    
+        for my $plugin ( @confs ) {
+            msg(loc("Found config '%1'", $plugin),0);
+            
+            ### if we already did this the /last/ time around dont 
+            ### run the setup agian.
+            if( my $loc = Module::Loaded::is_loaded( $plugin ) ) {
+                msg(loc("  Already loaded '%1' (%2)", $plugin, $loc), 0);
+                next;
+            } else {
+                msg(loc("  Loading config '%1'", $plugin),0);
+            
+                eval { load $plugin };
+                msg(loc("  Loaded '%1' (%2)", 
+                        $plugin, Module::Loaded::is_loaded( $plugin ) ), 0);
+            }                   
+            
+            if( $@ ) {
+                error(loc("Could not load '%1': %2", $plugin, $@));
+                next;
+            }     
+            
+            my $sub = $plugin->can('setup');
+            $sub->( $self ) if $sub;
+        }
+        
+        ### clean up the paths once more, just in case
+        $obj->_clean_up_paths;
+    
+        return 1;
+    }
+}
+=pod
+
+=head2 can_save( [$config_location] )
+
+Check if we can save the configuration to the specified file.
+If no file is provided, defaults to your personal config.
+
+Returns true if the file can be saved, false otherwise.
+
+=cut
+
+sub can_save {
+    my $self = shift;
+    my $file = shift || CONFIG_USER_FILE->();
+    
+    return 1 unless -e $file;
+
+    chmod 0644, $file;
+    return (-w $file);
+}
+
+=pod
+
+=head2 $file = $conf->save( [$package_name] )
+
+Saves the configuration to the package name you provided.
+If this package is not C<CPANPLUS::Config::System>, it will
+be saved in your C<.cpanplus> directory, otherwise it will
+be attempted to be saved in the system wide directory.
+
+If no argument is provided, it will default to your personal
+config.
+
+Returns the full path to the file if the config was saved, 
+false otherwise.
+
+=cut
+
+sub _config_pm_to_file {
+    my $self = shift;
+    my $pm   = shift or return;
+    my $dir  = shift || CONFIG_USER_LIB_DIR->();
+
+    ### only 3 types of files know: home, system and 'other'
+    ### so figure out where to save them based on their type
+    my $file;
+    if( $pm eq CONFIG_USER ) {
+        $file = CONFIG_USER_FILE->();   
+
+    } elsif ( $pm eq CONFIG_SYSTEM ) {
+        $file = CONFIG_SYSTEM_FILE->();
+        
+    ### third party file        
+    } else {
+        my $cfg_pkg = CONFIG . '::';
+        unless( $pm =~ /^$cfg_pkg/ ) {
+            error(loc(
+                "WARNING: Your config package '%1' is not in the '%2' ".
+                "namespace and will not be automatically detected by %3",
+                $pm, $cfg_pkg, 'CPANPLUS'
+            ));        
+        }                        
+    
+        $file = File::Spec->catfile(
+            $dir,
+            split( '::', $pm )
+        ) . '.pm';        
+    }
+
+    return $file;
+}
+
+
+sub save {
+    my $self    = shift;
+    my $pm      = shift || CONFIG_USER;
+    my $savedir = shift || '';
+    
+    my $file = $self->_config_pm_to_file( $pm, $savedir ) or return;
+    my $dir  = dirname( $file );
+    
+    unless( -d $dir ) {
+        $self->_mkdir( dir => $dir ) or (
+            error(loc("Can not create directory '%1' to save config to",$dir)),
+            return
+        )
+    }       
+    return unless $self->can_save($file);
+
+    ### find only accesors that are not private
+    my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors;
+
+    ### for dumping the values
+    use Data::Dumper;
+    
+    my @lines;
+    for my $acc ( @acc ) {
+        
+        push @lines, "### $acc section", $/;
+        
+        for my $key ( $self->conf->$acc->ls_accessors ) {
+            my $val = Dumper( $self->conf->$acc->$key );
+        
+            $val =~ s/\$VAR1\s+=\s+//;
+            $val =~ s/;\n//;
+        
+            push @lines, '$'. "conf->set_${acc}( $key => $val );", $/;
+        }
+        push @lines, $/,$/;
+
+    }
+
+    my $str = join '', map { "    $_" } @lines;
+
+    ### use a variable to make sure the pod parser doesn't snag it
+    my $is      = '=';
+    my $time    = gmtime;
+   
+    
+    my $msg     = <<_END_OF_CONFIG_;
+###############################################
+###                                         
+###  Configuration structure for $pm        
+###                                         
+###############################################
+
+#last changed: $time GMT
+
+### minimal pod, so you can find it with perldoc -l, etc
+${is}pod
+
+${is}head1 NAME
+
+$pm
+
+${is}head1 DESCRIPTION
+
+This is a CPANPLUS configuration file. Editing this
+config changes the way CPANPLUS will behave
+
+${is}cut
+
+package $pm;
+
+use strict;
+
+sub setup {
+    my \$conf = shift;
+    
+$str
+
+    return 1;    
+} 
+
+1;
+
+_END_OF_CONFIG_
+
+    $self->_move( file => $file, to => "$file~" ) if -f $file;
+
+    my $fh = new FileHandle;
+    $fh->open(">$file")
+        or (error(loc("Could not open '%1' for writing: %2", $file, $!)),
+            return );
+
+    $fh->print($msg);
+    $fh->close;
+
+    return $file;
+}
+
+=pod
+
+=head2 options( type => TYPE )
+
+Returns a list of all valid config options given a specific type
+(like for example C<conf> of C<program>) or false if the type does
+not exist
+
+=cut
+
+sub options {
+    my $self = shift;
+    my $conf = $self->conf;
+    my %hash = @_;
+
+    my $type;
+    my $tmpl = {
+        type    => { required       => 1, default   => '',
+                     strict_type    => 1, store     => \$type },
+    };
+
+    check($tmpl, \%hash) or return;
+
+    my %seen;
+    return sort grep { !$seen{$_}++ }
+                map { $_->$type->ls_accessors if $_->can($type)  } 
+                $self->conf;
+    return;
+}
+
+=pod
+
+=head1 ACCESSORS
+
+Accessors that start with a C<_> are marked private -- regular users
+should never need to use these.
+
+=head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] );
+
+The C<get_*> style accessors merely retrieves one or more desired
+config options.
+
+=head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
+
+The C<set_*> style accessors set the current value for one
+or more config options and will return true upon success, false on
+failure.
+
+=head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
+
+The C<add_*> style accessor adds a new key to a config key.
+
+Currently, the following accessors exist:
+
+=over 4
+
+=item set|get_conf
+
+Simple configuration directives like verbosity and favourite shell.
+
+=item set|get_program
+
+Location of helper programs.
+
+=item _set|_get_build
+
+Locations of where to put what files for CPANPLUS.
+
+=item _set|_get_source
+
+Locations and names of source files locally.
+
+=item _set|_get_mirror
+
+Locations and names of source files remotely.
+
+=item _set|_get_dist
+
+Mapping of distribution format names to modules.
+
+=item _set|_get_fetch
+
+Special settings pertaining to the fetching of files.
+
+=item _set|_get_daemon
+
+Settings for C<cpanpd>, the CPANPLUS daemon.
+
+=back
+
+=cut
+
+sub AUTOLOAD {
+    my $self    = shift;
+    my $conf    = $self->conf;
+
+    my $name    = $AUTOLOAD;
+    $name       =~ s/.+:://;
+
+    my ($private, $action, $field) =
+                $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;
+
+    my $type = '';
+    $type .= '_'    if $private;
+    $type .= $field if $field;
+
+    unless ( $conf->can($type) ) {
+        error( loc("Invalid method type: '%1'", $name) );
+        return;
+    }
+
+    unless( scalar @_ ) {
+        error( loc("No arguments provided!") );
+        return;
+    }
+
+    ### retrieve a current value for an existing key ###
+    if( $action eq 'get' ) {
+        for my $key (@_) {
+            my @list = ();
+
+            ### get it from the user config first
+            if( $conf->can($type) and $conf->$type->can($key) ) {
+                push @list, $conf->$type->$key;
+
+            ### XXX EU::AI compatibility hack to provide lookups like in
+            ### cpanplus 0.04x; we renamed ->_get_build('base') to
+            ### ->get_conf('base')
+            } elsif ( $type eq '_build' and $key eq 'base' ) {
+                return $self->get_conf($key);  
+                
+            } else {     
+                error( loc(q[No such key '%1' in field '%2'], $key, $type) );
+                return;
+            }
+
+            return wantarray ? @list : $list[0];
+        }
+
+    ### set an existing key to a new value ###
+    } elsif ( $action eq 'set' ) {
+        my %args = @_;
+
+        while( my($key,$val) = each %args ) {
+
+            if( $conf->can($type) and $conf->$type->can($key) ) {
+                $conf->$type->$key( $val );
+                
+            } else {
+                error( loc(q[No such key '%1' in field '%2'], $key, $type) );
+                return;
+            }
+        }
+
+        return 1;
+
+    ### add a new key to the config ###
+    } elsif ( $action eq 'add' ) {
+        my %args = @_;
+
+        while( my($key,$val) = each %args ) {
+
+            if( $conf->$type->can($key) ) {
+                error( loc( q[Key '%1' already exists for field '%2'],
+                            $key, $type));
+                return;
+            } else {
+                $conf->$type->mk_accessors( $key );
+                $conf->$type->$key( $val );
+            }
+        }
+        return 1;
+
+    } else {
+
+        error( loc(q[Unknown action '%1'], $action) );
+        return;
+    }
+}
+
+sub DESTROY { 1 };
+
+1;
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c) 
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it 
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
diff --git a/lib/CPANPLUS/Configure/Setup.pm b/lib/CPANPLUS/Configure/Setup.pm
new file mode 100644 (file)
index 0000000..81ee2ca
--- /dev/null
@@ -0,0 +1,1628 @@
+package CPANPLUS::Configure::Setup;
+
+use strict;
+use vars    qw(@ISA);
+
+use base    qw[CPANPLUS::Internals::Utils];
+use base    qw[Object::Accessor];
+
+use Config;
+use Term::UI;
+use Module::Load;
+use Term::ReadLine;
+
+
+use CPANPLUS::Internals::Utils;
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Error;
+
+use IPC::Cmd                    qw[can_run];
+use Params::Check               qw[check];
+use Module::Load::Conditional   qw[check_install];
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+
+### silence Term::UI
+$Term::UI::VERBOSE = 0;
+
+#Can't ioctl TIOCGETP: Unknown error
+#Consider installing Term::ReadKey from CPAN site nearby
+#        at http://www.perl.com/CPAN
+#Or use
+#        perl -MCPAN -e shell
+#to reach CPAN. Falling back to 'stty'.
+#        If you do not want to see this warning, set PERL_READLINE_NOWARN
+#in your environment.
+#'stty' is not recognized as an internal or external command,
+#operable program or batch file.
+#Cannot call `stty': No such file or directory at C:/Perl/site/lib/Term/ReadLine/
+
+### setting this var in the meantime to avoid this warning ###
+$ENV{PERL_READLINE_NOWARN} = 1;
+
+
+sub new {
+    my $class = shift;
+    my %hash  = @_;
+
+    my $tmpl = {
+        configure_object => { },
+        term             => { },
+        backend          => { },
+        autoreply        => { default => 0, },
+        skip_mirrors     => { default => 0, },
+        use_previous     => { default => 1, },
+        config_type      => { default => CONFIG_USER },
+    };
+
+    my $args = check( $tmpl, \%hash ) or return;
+
+    ### initialize object
+    my $obj = $class->SUPER::new( keys %$tmpl );
+    for my $acc ( $obj->ls_accessors ) {
+        $obj->$acc( $args->{$acc} );
+    }     
+    
+    ### otherwise there's a circular use ###
+    load CPANPLUS::Configure;
+    load CPANPLUS::Backend;
+
+    $obj->configure_object( CPANPLUS::Configure->new() )
+        unless $obj->configure_object;
+        
+    $obj->backend( CPANPLUS::Backend->new( $obj->configure_object ) )
+        unless $obj->backend;
+
+    ### use empty string in case user only has T::R::Stub -- it complains
+    $obj->term( Term::ReadLine->new('') ) 
+        unless $obj->term;
+
+    ### enable autoreply if that was passed ###
+    $Term::UI::AUTOREPLY = $obj->autoreply;
+
+    return $obj;
+}
+
+sub init {
+    my $self = shift;
+    my $term = $self->term;
+    
+    ### default setting, unless changed
+    $self->config_type( CONFIG_USER ) unless $self->config_type;
+    
+    my $save = loc('Save & exit');
+    my $exit = loc('Quit without saving');
+    my @map  = (
+        # key on the display                        # method to dispatch to
+        [ loc('Select Configuration file')      => '_save_where'        ],
+        [ loc('Setup CLI Programs')             => '_setup_program'     ],
+        [ loc('Setup CPANPLUS Home directory')  => '_setup_base'        ],
+        [ loc('Setup FTP/Email settings')       => '_setup_ftp'         ],
+        [ loc('Setup basic preferences')        => '_setup_conf'        ],
+        [ loc('Setup installer settings')       => '_setup_installer'   ],
+        [ loc('Select mirrors'),                => '_setup_hosts'       ],      
+        [ loc('Edit configuration file')        => '_edit'              ],    
+        [ $save                                 => '_save'              ],
+        [ $exit                                 => 1                    ],             
+    );
+
+    my @keys = map { $_->[0] } @map;    # sorted keys
+    my %map  = map { @$_     } @map;    # lookup hash
+   
+    PICK_SECTION: {
+        print loc("
+=================>      MAIN MENU       <=================        
+        
+Welcome to the CPANPLUS configuration. Please select which
+parts you wish to configure
+
+Defaults are taken from your current configuration.
+If you would save now, your settings would be written to:
+    
+    %1
+    
+        ", $self->config_type );
+    
+        my $choice = $term->get_reply(
+                            prompt  => "Section to configure:",
+                            choices => \@keys,
+                            default => $keys[0]
+                        );       
+               
+        ### exit configuration?
+        if( $choice eq $exit ) {
+            print loc("
+Quitting setup, changes will not be saved.
+            ");
+            return 1;
+        }      
+            
+        my $method = $map{$choice};
+        
+        my $rv = $self->$method or print loc("
+There was an error setting up this section. You might want to try again
+        ");
+
+        ### was it save & exit?
+        if( $choice eq $save and $rv ) {
+            print loc("
+Quitting setup, changes are saved to '%1'
+            ", $self->config_type 
+            );
+            return 1;
+        }
+
+        ### otherwise, present choice again
+        redo PICK_SECTION;
+    }  
+
+    return 1;
+}
+
+
+
+### sub that figures out what kind of config type the user wants
+sub _save_where {
+    my $self = shift;
+    my $term = $self->term;
+    my $conf = $self->configure_object;
+
+
+    ASK_CONFIG_TYPE: {
+    
+        print loc( q[  
+Where would you like to save your CPANPLUS Configuration file?
+
+If you want to configure CPANPLUS for this user only, 
+select the '%1' option.
+The file will then be saved in your homedirectory.
+
+If you are the system administrator of this machine, 
+and would like to make this config available globally, 
+select the '%2' option.
+The file will be then be saved in your CPANPLUS 
+installation directory.
+
+        ], CONFIG_USER, CONFIG_SYSTEM );
+    
+
+        ### ask what config type we should save to
+        my $type = $term->get_reply(
+                        prompt  => loc("Type of configuration file"),
+                        default => $self->config_type || CONFIG_USER,
+                        choices => [CONFIG_USER, CONFIG_SYSTEM],
+                  );
+    
+        my $file = $conf->_config_pm_to_file( $type );
+        
+        ### can we save to this file?
+        unless( $conf->can_save( $file ) ) {
+            error(loc(
+                "Can not save to file '%1'-- please check permissions " .
+                "and try again", $file       
+            ));
+            
+            redo ASK_CONFIG_FILE;
+        } 
+        
+        ### you already have the file -- are we allowed to overwrite
+        ### or should we try again?
+        if ( -e $file and -w _ ) {
+            print loc(q[
+I see you already have this file:
+    %1
+
+If you continue & save this file, the previous version will be overwritten.
+
+            ], $file );
+            
+            redo ASK_CONFIG_TYPE 
+                unless $term->ask_yn(
+                    prompt  => loc( "Shall I overwrite it?"),
+                    default => 'n',
+                );
+        }
+        
+        print $/, loc("Using '%1' as your configuration type", $type);
+        
+        return $self->config_type($type);
+    }            
+}
+
+
+### setup the build & cache dirs
+sub _setup_base {
+    my $self = shift;
+    my $term = $self->term;
+    my $conf = $self->configure_object;
+
+    my $base = $conf->get_conf('base');
+    my $home = File::Spec->catdir( $self->_home_dir, DOT_CPANPLUS );
+    
+    print loc("
+CPANPLUS needs a directory of its own to cache important index
+files and maybe keep a temporary mirror of CPAN files.  
+This may be a site-wide directory or a personal directory.
+
+For a single-user installation, we suggest using your home directory.
+
+");
+
+    my $where;
+    ASK_HOME_DIR: {
+        my $other = loc('Somewhere else');
+        if( $base and ($base ne $home) ) {
+            print loc("You have several choices:");
+
+            $where = $term->get_reply(
+                        prompt  => loc('Please pick one'),
+                        choices => [$home, $base, $other],
+                        default => $home,
+                    );
+        } else {
+            $where = $base;
+        }
+
+        if( $where and -d $where ) {
+            print loc("
+I see you already have a directory:
+    %1
+    
+            "), $where;
+
+            my $yn = $term->ask_yn(
+                            prompt  => loc('Should I use it?'),
+                            default => 'y',
+                        );
+            $where = '' unless $yn;
+        }
+
+        if( $where and ($where ne $other) and not -d $where ) {
+            if (!$self->_mkdir( dir => $where ) ) {
+                print   "\n", loc("Unable to create directory '%1'", $where);
+                redo ASK_HOME_DIR;
+            }
+
+        } elsif( not $where or ($where eq $other) ) {
+            print loc("
+First of all, I'd like to create this directory.
+
+            ");
+
+            NEW_HOME: {
+                $where = $term->get_reply(
+                                prompt  => loc('Where shall I create it?'),
+                                default => $home,
+                            );
+
+                my $again;
+                if( -d $where and not -w _ ) {
+                    print "\n", loc("I can't seem to write in this directory");
+                    $again++;
+                } elsif (!$self->_mkdir( dir => $where ) ) {
+                    print "\n", loc("Unable to create directory '%1'", $where);
+                    $again++;
+                }
+
+                if( $again ) {
+                    print "\n", loc('Please select another directory'), "\n\n";
+                    redo NEW_HOME;
+                }
+            }
+        }
+    }
+
+    ### tidy up the path and store it
+    $where = File::Spec->rel2abs($where);
+    $conf->set_conf( base => $where );
+
+    ### create subdirectories ###
+    my @dirs =
+        File::Spec->catdir( $where, $self->_perl_version(perl => $^X),
+                            $conf->_get_build('moddir') ),
+        map {
+            File::Spec->catdir( $where, $conf->_get_build($_) )
+        } qw[autdir distdir];
+
+    for my $dir ( @dirs ) {
+        unless( $self->_mkdir( dir => $dir ) ) {
+            warn loc("I wasn't able to create '%1'", $dir), "\n";
+        }
+    }
+
+    ### clear away old storable images before 0.031
+    for my $src (qw[dslip mailrc packages]) {
+        1 while unlink File::Spec->catfile( $where, $src );
+
+    }
+
+    print loc(q[
+Your CPANPLUS build and cache directory has been set to:
+    %1
+    
+    ], $where);
+
+    return 1;
+}
+
+sub _setup_ftp {
+    my $self = shift;
+    my $term = $self->term;
+    my $conf = $self->configure_object;
+
+    #########################
+    ## are you a pacifist? ##
+    #########################
+
+    print loc("
+If you are connecting through a firewall or proxy that doesn't handle
+FTP all that well you can use passive FTP.
+
+");
+
+    my $yn = $term->ask_yn(
+                prompt  => loc("Use passive FTP?"),
+                default => $conf->get_conf('passive'),
+            );
+
+    $conf->set_conf(passive => $yn);
+
+    ### set the ENV var as well, else it won't get set till AFTER
+    ### the configuration is saved. but we fetch files BEFORE that.
+    $ENV{FTP_PASSIVE} = $yn;
+
+    print "\n";
+    print $yn
+            ? loc("I will use passive FTP.")
+            : loc("I won't use passive FTP.");
+    print "\n";
+
+    #############################
+    ## should fetches timeout? ##
+    #############################
+
+    print loc("
+CPANPLUS can specify a network timeout for downloads (in whole seconds).
+If none is desired (or to skip this question), enter '0'.
+
+");
+
+    my $timeout = 0 + $term->get_reply(
+                prompt  => loc("Network timeout for downloads"),
+                default => $conf->get_conf('timeout') || 0,
+                allow   => qr/(?!\D)/,            ### whole numbers only
+            );
+
+    $conf->set_conf(timeout => $timeout);
+
+    print "\n";
+    print $timeout
+            ? loc("The network timeout for downloads is %1 seconds.", $timeout)
+            : loc("The network timeout for downloads is not set.");
+    print "\n";
+
+    ############################
+    ## where can I reach you? ##
+    ############################
+
+    print loc("
+What email address should we send as our anonymous password when
+fetching modules from CPAN servers?  Some servers will NOT allow you to
+connect without a valid email address, or at least something that looks
+like one.
+Also, if you choose to report test results at some point, a valid email
+is required for the 'from' field, so choose wisely.
+
+    ");
+
+    my $other   = 'Something else';
+    my @choices = (DEFAULT_EMAIL, $Config{cf_email}, $other);
+    my $current = $conf->get_conf('email');
+
+    ### if your current address is not in the list, add it to the choices
+    unless (grep { $_ eq $current } @choices) {
+          unshift @choices, $current;
+    }
+    
+    my $email = $term->get_reply(
+                    prompt  => loc('Which email address shall I use?'),
+                    default => $current || $choices[0],
+                    choices => \@choices,
+                );
+
+    if( $email eq $other ) {
+        EMAIL: {
+            $email = $term->get_reply(
+                        prompt  => loc('Email address: '),
+                    );
+            
+            unless( $self->_valid_email($email) ) {
+                print loc("
+You did not enter a valid email address, please try again!
+                ") if length $email;
+
+                redo EMAIL;
+            }
+        }
+    }
+
+    print loc("
+Your 'email' is now:
+    %1
+    
+    ", $email);
+
+    $conf->set_conf( email => $email );
+
+    return 1;
+}
+
+
+### commandline programs
+sub _setup_program {
+    my $self = shift;
+    my $term = $self->term;
+    my $conf = $self->configure_object;
+
+    print loc("
+CPANPLUS can use command line utilities to do certain
+tasks, rather than use perl modules.
+
+If you wish to use a certain command utility, just enter
+the full path (or accept the default). If you do not wish
+to use it, enter a single space.
+
+Note that the paths you provide should not contain spaces, which is
+needed to make a distinction between program name and options to that
+program. For Win32 machines, you can use the short name for a path,
+like '%1'.
+
+    ", 'c:\Progra~1\prog.exe' );
+
+    for my $prog ( sort $conf->options( type => 'program') ) {
+        PROGRAM: {
+            print loc("Where can I find your '%1' utility? ".
+                      "(Enter a single space to disable)", $prog );
+            
+            my $loc = $term->get_reply(
+                            prompt  => "Path to your '$prog'",
+                            default => $conf->get_program( $prog ),
+                        );       
+                        
+            ### empty line clears it            
+            my $cmd     = $loc =~ /^\s*$/ ? undef : $loc;
+            my ($bin)   = $cmd =~ /^(\S+)/;
+            
+            ### did you provide a valid program ?
+            if( $bin and not can_run( $bin ) ) {
+                print "\n";
+                print loc("Can not find the binary '%1' in your path!", $bin);
+                redo PROGRAM;
+            }
+
+            ### make is special -- we /need/ it!
+            if( $prog eq 'make' and not $bin ) {
+                print loc(
+                    "==> Without your '%1' utility, I can not function! <==",
+                    'make'
+                );
+                print loc("Please provide one!");
+                
+                ### show win32 where to download
+                if ( $^O eq 'MSWin32' ) {            
+                    print loc("You can get '%1' from:", NMAKE);
+                    print "\t". NMAKE_URL ."\n";
+                }
+                print "\n";
+                redo PROGRAM;                    
+            }
+
+            $conf->set_program( $prog => $cmd );
+            print $cmd
+                ? loc(  "Your '%1' utility has been set to '%2'", 
+                        $prog, $cmd )
+                : loc(  "Your '%1' has been disabled", $prog );           
+            print "\n";
+        }
+    }
+    
+    return 1;
+}    
+
+sub _setup_installer {
+    my $self = shift;
+    my $term = $self->term;
+    my $conf = $self->configure_object;
+
+    my $none = 'None';
+    {   
+        print loc("
+CPANPLUS uses binary programs as well as Perl modules to accomplish
+various tasks. Normally, CPANPLUS will prefer the use of Perl modules
+over binary programs.
+
+You can change this setting by making CPANPLUS prefer the use of
+certain binary programs if they are available.
+
+        ");
+        
+        ### default to using binaries if we don't have compress::zlib only
+        ### -- it'll get very noisy otherwise
+        my $type = 'prefer_bin';
+        my $yn = $term->ask_yn(
+            prompt  => loc("Should I prefer the use of binary programs?"),
+            default => $conf->get_conf( $type ),
+        );
+
+        print $yn
+                ? loc("Ok, I will prefer to use binary programs if possible.")
+                : loc("Ok, I will prefer to use Perl modules if possible.");
+        print "\n\n";
+
+
+        $conf->set_conf( $type => $yn );
+    }
+
+    {
+        print loc("
+Makefile.PL is run by perl in a separate process, and accepts various
+flags that controls the module's installation.  For instance, if you
+would like to install modules to your private user directory, set
+'makemakerflags' to:
+
+LIB=~/perl/lib INSTALLMAN1DIR=~/perl/man/man1 INSTALLMAN3DIR=~/perl/man/man3
+
+and be sure that you do NOT set UNINST=1 in 'makeflags' below.
+
+Enter a name=value list separated by whitespace, but quote any embedded
+spaces that you want to preserve.  (Enter a space to clear any existing
+settings.)
+
+If you don't understand this question, just press ENTER.
+
+        ");
+
+        my $type = 'makemakerflags';
+        my $flags = $term->get_reply(
+                            prompt  => 'Makefile.PL flags?',
+                            default => $conf->get_conf($type),
+                    );
+
+        $flags = '' if $flags eq $none || $flags !~ /\S/;
+
+        print   "\n", loc("Your '%1' have been set to:", 'Makefile.PL flags'),
+                "\n    ", ( $flags ? $flags : loc('*nothing entered*')),
+                "\n\n";
+
+        $conf->set_conf( $type => $flags );
+    }
+
+    {
+        print loc("
+Like Makefile.PL, we run 'make' and 'make install' as separate processes.
+If you have any parameters (e.g. '-j3' in dual processor systems) you want
+to pass to the calls, please specify them here.
+
+In particular, 'UNINST=1' is recommended for root users, unless you have
+fine-tuned ideas of where modules should be installed in the \@INC path.
+
+Enter a name=value list separated by whitespace, but quote any embedded
+spaces that you want to preserve.  (Enter a space to clear any existing
+settings.)
+
+Again, if you don't understand this question, just press ENTER.
+
+        ");
+        my $type        = 'makeflags';
+        my $flags   = $term->get_reply(
+                                prompt  => 'make flags?',
+                                default => $conf->get_conf($type),
+                            );
+
+        $flags = '' if $flags eq $none || $flags !~ /\S/;
+
+        print   "\n", loc("Your '%1' have been set to:", $type),
+                "\n    ", ( $flags ? $flags : loc('*nothing entered*')),
+                "\n\n";
+
+        $conf->set_conf( $type => $flags );
+    }
+
+    {
+        print loc("
+An alternative to ExtUtils::MakeMaker and Makefile.PL there's a module
+called Module::Build which uses a Build.PL.
+
+If you would like to specify any flags to pass when executing the
+Build.PL (and Build) script, please enter them below.
+
+For instance, if you would like to install modules to your private
+user directory, you could enter:
+
+    install_base=/my/private/path
+
+Or to uninstall old copies of modules before updating, you might
+want to enter:
+
+    uninst=1
+
+Again, if you don't understand this question, just press ENTER.
+
+        ");
+
+        my $type    = 'buildflags';
+        my $flags   = $term->get_reply(
+                                prompt  => 'Build.PL and Build flags?',
+                                default => $conf->get_conf($type),
+                            );
+
+        $flags = '' if $flags eq $none || $flags !~ /\S/;
+
+        print   "\n", loc("Your '%1' have been set to:",
+                            'Build.PL and Build flags'),
+                "\n    ", ( $flags ? $flags : loc('*nothing entered*')),
+                "\n\n";
+
+        $conf->set_conf( $type => $flags );
+    }
+
+    ### use EU::MM or module::build? ###
+    {
+        print loc("
+Some modules provide both a Build.PL (Module::Build) and a Makefile.PL
+(ExtUtils::MakeMaker).  By default, CPANPLUS prefers Makefile.PL.
+
+Module::Build support is not bundled standard with CPANPLUS, but 
+requires you to install 'CPANPLUS::Dist::Build' from CPAN.
+
+Although Module::Build is a pure perl solution, which means you will
+not need a 'make' binary, it does have some limitations. The most
+important is that CPANPLUS is unable to uninstall any modules installed
+by Module::Build.
+
+Again, if you don't understand this question, just press ENTER.
+
+        ");
+        my $type = 'prefer_makefile';
+        my $yn = $term->ask_yn(
+                    prompt  => loc("Prefer Makefile.PL over Build.PL?"),
+                    default => $conf->get_conf($type),
+                 );
+
+        $conf->set_conf( $type => $yn );
+    }
+
+    {
+        print loc('
+If you like, CPANPLUS can add extra directories to your @INC list during
+startup. These will just be used by CPANPLUS and will not change your
+external environment or perl interpreter.  Enter a space separated list of
+pathnames to be added to your @INC, quoting any with embedded whitespace.
+(To clear the current value enter a single space.)
+
+        ');
+
+        my $type    = 'lib';
+        my $flags = $term->get_reply(
+                        prompt  => loc('Additional @INC directories to add?'),
+                        default => (join " ", @{$conf->get_conf($type) || []} ),
+                    );
+
+        my $lib;
+        unless( $flags =~ /\S/ ) {
+            $lib = [];
+        } else {
+            (@$lib) = $flags =~  m/\s*("[^"]+"|'[^']+'|[^\s]+)/g;
+        }
+
+        print "\n", loc("Your additional libs are now:"), "\n";
+
+        print scalar @$lib
+                        ? map { "    $_\n" } @$lib
+                        : "    ", loc("*nothing entered*"), "\n";
+        print "\n\n";
+
+        $conf->set_conf( $type => $lib );
+    }
+    
+    return 1;
+}    
+    
+
+sub _setup_conf {
+    my $self = shift;
+    my $term = $self->term;
+    my $conf = $self->configure_object;
+
+    my $none = 'None';
+    {
+        ############
+        ## noisy? ##
+        ############
+
+        print loc("
+In normal operation I can just give you basic information about what I
+am doing, or I can be more verbose and give you every little detail.
+
+        ");
+
+        my $type = 'verbose';
+        my $yn   = $term->ask_yn(
+                            prompt  => loc("Should I be verbose?"),
+                            default => $conf->get_conf( $type ),                        );
+
+        print "\n";
+        print $yn
+                ? loc("You asked for it!")
+                : loc("I'll try to be quiet");
+
+        $conf->set_conf( $type => $yn );
+    }
+
+    {
+        #######################
+        ## flush you animal! ##
+        #######################
+
+        print loc("
+In the interest of speed, we keep track of what modules were installed
+successfully and which failed in the current session.  We can flush this
+data automatically, or you can explicitly issue a 'flush' when you want
+to purge it.
+
+        ");
+
+        my $type = 'flush';
+        my $yn   = $term->ask_yn(
+                            prompt  => loc("Flush automatically?"),
+                            default => $conf->get_conf( $type ),
+                        );
+
+        print "\n";
+        print $yn
+                ? loc("I'll flush after every full module install.")
+                : loc("I won't flush until you tell me to.");
+
+        $conf->set_conf( $type => $yn );
+    }
+
+    {
+        #####################
+        ## force installs? ##
+        #####################
+
+        print loc("
+Usually, when a test fails, I won't install the module, but if you
+prefer, I can force the install anyway.
+
+        ");
+
+        my $type = 'force';
+        my $yn   = $term->ask_yn(
+                        prompt  => loc("Force installs?"),
+                        default => $conf->get_conf( $type ),
+                    );
+
+        print "\n";
+        print $yn
+                ? loc("I will force installs.")
+                : loc("I won't force installs.");
+
+        $conf->set_conf( $type => $yn );
+    }
+
+    {
+        ###################
+        ## about prereqs ##
+        ###################
+
+        print loc("
+Sometimes a module will require other modules to be installed before it
+will work.  CPANPLUS can attempt to install these for you automatically
+if you like, or you can do the deed yourself.
+
+If you would prefer that we NEVER try to install extra modules
+automatically, select NO.  (Usually you will want this set to YES.)
+
+If you would like to build modules to satisfy testing or prerequisites,
+but not actually install them, select BUILD.
+
+NOTE: This feature requires you to flush the 'lib' cache for longer
+running programs (refer to the CPANPLUS::Backend documentations for
+more details).
+
+Otherwise, select ASK to have us ask your permission to install them.
+
+        ");
+
+        my $type = 'prereqs';
+        
+        my @map = (
+            [ PREREQ_IGNORE,                                # conf value 
+              loc('No, do not install prerequisites'),      # UI Value   
+              loc("I won't install prerequisites")          # diag message
+            ],
+            [ PREREQ_INSTALL,
+              loc('Yes, please install prerequisites'),  
+              loc("I will install prerequisites")     
+            ],
+            [ PREREQ_ASK,    
+              loc('Ask me before installing a prerequisite'),  
+              loc("I will ask permission to install") 
+            ],
+            [ PREREQ_BUILD,  
+              loc('Build prerequisites, but do not install them'),
+              loc( "I will only build, but not install prerequisites" )
+            ],
+        );
+       
+        my %reply = map { $_->[1] => $_->[0] } @map; # choice => value
+        my %diag  = map { $_->[1] => $_->[2] } @map; # choice => diag message
+        my %conf  = map { $_->[0] => $_->[1] } @map; # value => ui choice
+        
+        my $reply   = $term->get_reply(
+                        prompt  => loc('Follow prerequisites?'),
+                        default => $conf{ $conf->get_conf( $type ) },
+                        choices => [ @conf{ sort keys %conf } ],
+                    );
+        print "\n";
+        
+        my $value = $reply{ $reply };
+        my $diag  = $diag{  $reply };
+
+        $conf->set_conf( $type => $value );
+        print $diag, "\n";
+    }
+
+    {   print loc("
+Modules in the CPAN archives are protected with md5 checksums.
+
+This requires the Perl module Digest::MD5 to be installed (which
+CPANPLUS can do for you later);
+
+        ");
+        my $type    = 'md5';
+        
+        my $yn = $term->ask_yn(
+                    prompt  => loc("Shall I use the MD5 checksums?"),
+                    default => $conf->get_conf( $type ),
+                );
+
+        print $yn
+                ? loc("I will use the MD5 checksums if you have it")
+                : loc("I won't use the MD5 checksums");
+
+        $conf->set_conf( $type => $yn );
+
+    }
+
+    
+    {   ###########################################
+        ## sally sells seashells by the seashore ##
+        ###########################################
+
+        print loc("
+By default CPANPLUS uses its own shell when invoked.  If you would prefer
+a different shell, such as one you have written or otherwise acquired,
+please enter the full name for your shell module.
+
+        ");
+
+        my $type    = 'shell';
+        my $other   = 'Other';
+        my @choices = (qw|  CPANPLUS::Shell::Default
+                            CPANPLUS::Shell::Classic |, 
+                            $other );
+        my $default = $conf->get_conf($type);
+
+        unshift @choices, $default unless grep { $_ eq $default } @choices;
+
+        my $reply = $term->get_reply(
+            prompt  => loc('Which CPANPLUS shell do you want to use?'),
+            default => $default,
+            choices => \@choices,
+        );
+
+        if( $reply eq $other ) {
+            SHELL: {
+                $reply = $term->get_reply(
+                    prompt => loc(  'Please enter the name of the shell '.
+                                    'you wish to use: '),
+                );
+
+                unless( check_install( module => $reply ) ) {
+                    print "\n", 
+                          loc("Could not find '$reply' in your path " .
+                          "-- please try again"), 
+                          "\n";
+                    redo SHELL;
+                }
+            }
+        }
+
+        print "\n", loc("Your shell is now:   %1", $reply), "\n\n";
+
+        $conf->set_conf( $type => $reply );
+    }
+
+    {
+        ###################
+        ## use storable? ##
+        ###################
+
+        print loc("
+To speed up the start time of CPANPLUS, and maintain a cache over
+multiple runs, we can use Storable to freeze some information.
+Would you like to do this?
+
+");
+        my $type    = 'storable';
+        my $yn      = $term->ask_yn(
+                                prompt  => loc("Use Storable?"),
+                                default => $conf->get_conf( $type ) ? 1 : 0,
+                            );
+        print "\n";
+        print $yn
+                ? loc("I will use Storable if you have it")
+                : loc("I will not use Storable");
+
+        $conf->set_conf( $type => $yn );
+    }
+
+    {
+        ###################
+        ## use cpantest? ##
+        ###################
+
+        print loc("
+CPANPLUS has support for the Test::Reporter module, which can be utilized
+to report success and failures of modules installed by CPANPLUS.  Would
+you like to do this?  Note that you will still be prompted before
+sending each report.
+
+If you don't have all the required modules installed yet, you should
+consider installing '%1'
+
+This package bundles all the required modules to enable test reporting
+and querying from CPANPLUS.
+You can do so straight after this installation.
+
+        ", 'Bundle::CPANPLUS::Test::Reporter');
+
+        my $type = 'cpantest';
+        my $yn   = $term->ask_yn(
+                        prompt  => loc('Report test results?'),
+                        default => $conf->get_conf( $type ) ? 1 : 0,
+                    );
+
+        print "\n";
+        print $yn
+                ? loc("I will prompt you to report test results")
+                : loc("I won't prompt you to report test results");
+
+        $conf->set_conf( $type => $yn );
+    }
+
+    {
+        ###################################
+        ## use cryptographic signatures? ##
+        ###################################
+
+        print loc("
+The Module::Signature extension allows CPAN authors to sign their
+distributions using PGP signatures.  Would you like to check for
+module's cryptographic integrity before attempting to install them?
+Note that this requires either the 'gpg' utility or Crypt::OpenPGP
+to be installed.
+
+        ");
+        my $type = 'signature';
+
+        my $yn = $term->ask_yn(
+                            prompt  => loc('Shall I check module signatures?'),
+                            default => $conf->get_conf($type) ? 1 : 0,
+                        );
+
+        print "\n";
+        print $yn
+                ? loc("Ok, I will attempt to check module signatures.")
+                : loc("Ok, I won't attempt to check module signatures.");
+
+        $conf->set_conf( $type => $yn );
+    }
+
+    return 1;
+}
+
+sub _setup_hosts {
+    my $self = shift;
+    my $term = $self->term;
+    my $conf = $self->configure_object;
+
+
+    if( scalar @{ $conf->get_conf('hosts') } ) {
+
+        my $hosts;
+        for my $href ( @{$conf->get_conf('hosts')} ) {
+            $hosts .= "\t$href->{scheme}://$href->{host}$href->{path}\n";
+        }
+
+        print loc("
+I see you already have some hosts selected:
+
+$hosts
+
+If you'd like to stick with your current settings, just select 'Yes'.
+Otherwise, select 'No' and you can reconfigure your hosts
+
+");
+        my $yn = $term->ask_yn(
+                        prompt  => loc("Would you like to keep your current hosts?"),
+                        default => 'y',
+                    );
+        return 1 if $yn;
+    }
+
+    my @hosts;
+    MAIN: {
+
+        print loc("
+Now we need to know where your favorite CPAN sites are located. Make a
+list of a few sites (just in case the first on the array won't work).
+
+If you are mirroring CPAN to your local workstation, specify a file:
+URI by picking the CUSTOM option.
+
+Otherwise, let us fetch the official CPAN mirror list and you can pick
+the mirror that suits you best from a list by using the MIRROR option;
+First, pick a nearby continent and country. Then, you will be presented
+with a list of URLs of CPAN mirrors in the country you selected. Select
+one or more of those URLs.
+
+Note, the latter option requires a working net connection.
+
+You can select VIEW to see your current selection and QUIT when you
+are done.
+
+");
+
+        my $reply = $term->get_reply(
+                        prompt  => loc('Please choose an option'),
+                        choices => [qw|Mirror Custom View Quit|],
+                        default => 'Mirror',
+                    );
+
+        goto MIRROR if $reply eq 'Mirror';
+        goto CUSTOM if $reply eq 'Custom';
+        goto QUIT   if $reply eq 'Quit';
+
+        $self->_view_hosts(@hosts) if $reply eq 'View';
+        redo MAIN;
+    }
+
+    my $mirror_file;
+    my $hosts;
+    MIRROR: {
+        $mirror_file    ||= $self->_get_mirrored_by               or return;
+        $hosts          ||= $self->_parse_mirrored_by($mirror_file) or return;
+
+        my ($continent, $country, $host) = $self->_guess_from_timezone( $hosts );
+
+        CONTINENT: {
+            my %seen;
+            my @choices =   sort map {
+                                $_->{'continent'}
+                            } grep {
+                                not $seen{$_->{'continent'}}++
+                            } values %$hosts;
+            push @choices,  qw[Custom Up Quit];
+
+            my $reply   = $term->get_reply(
+                                prompt  => loc('Pick a continent'),
+                                default => $continent,
+                                choices => \@choices,
+                            );
+
+            goto MAIN   if $reply eq 'Up';
+            goto CUSTOM if $reply eq 'Custom';
+            goto QUIT   if $reply eq 'Quit';
+
+            $continent = $reply;
+        }
+
+        COUNTRY: {
+            my %seen;
+            my @choices =   sort map {
+                                $_->{'country'}
+                            } grep {
+                                not $seen{$_->{'country'}}++
+                            } grep {
+                                ($_->{'continent'} eq $continent)
+                            } values %$hosts;
+            push @choices,  qw[Custom Up Quit];
+
+            my $reply   = $term->get_reply(
+                                prompt  => loc('Pick a country'),
+                                default => $country,
+                                choices => \@choices,
+                            );
+
+            goto CONTINENT  if $reply eq 'Up';
+            goto CUSTOM     if $reply eq 'Custom';
+            goto QUIT       if $reply eq 'Quit';
+
+            $country = $reply;
+        }
+
+        HOST: {
+            my @list =  grep {
+                            $_->{'continent'}   eq $continent and
+                            $_->{'country'}     eq $country
+                        } values %$hosts;
+
+            my %map; my $default;
+            for my $href (@list) {
+                for my $con ( @{$href->{'connections'}} ) {
+                    next unless length $con->{'host'};
+
+                    my $entry   = $con->{'scheme'} . '://' . $con->{'host'};
+                    $default    = $entry if $con->{'host'} eq $host;
+
+                    $map{$entry} = $con;
+                }
+            }
+
+            CHOICE: {
+                
+                ### doesn't play nice with Term::UI :(
+                ### should make t::ui figure out pager opens
+                #$self->_pager_open;     # host lists might be long
+            
+                print loc("
+You can enter multiple sites by seperating them by a space.
+For example:
+    1 4 2 5
+                ");    
+            
+                my @reply = $term->get_reply(
+                                    prompt  => loc('Please pick a site: '),
+                                    choices => [sort(keys %map), 
+                                                qw|Custom View Up Quit|],
+                                    default => $default,
+                                    multi   => 1,
+                            );
+                #$self->_pager_close;
+    
+
+                goto COUNTRY    if grep { $_ eq 'Up' }      @reply;
+                goto CUSTOM     if grep { $_ eq 'Custom' }  @reply;
+                goto QUIT       if grep { $_ eq 'Quit' }    @reply;
+
+                ### add the host, but only if it's not on the stack already ###
+                unless(  grep { $_ eq 'View' } @reply ) {
+                    for my $reply (@reply) {
+                        if( grep { $_ eq $map{$reply} } @hosts ) {
+                            print loc("Host '%1' already selected", $reply);
+                            print "\n\n";
+                        } else {
+                            push @hosts, $map{$reply}
+                        }
+                    }
+                }
+
+                $self->_view_hosts(@hosts);
+
+                goto QUIT if $self->autoreply;
+                redo CHOICE;
+            }
+        }
+    }
+
+    CUSTOM: {
+        print loc("
+If there are any additional URLs you would like to use, please add them
+now.  You may enter them separately or as a space delimited list.
+
+We provide a default fall-back URL, but you are welcome to override it
+with e.g. 'http://www.cpan.org/' if LWP, wget or curl is installed.
+
+(Enter a single space when you are done, or to simply skip this step.)
+
+Note that if you want to use a local depository, you will have to enter
+as follows:
+
+file://server/path/to/cpan
+
+if the file is on a server on your local network or as:
+
+file:///path/to/cpan
+
+if the file is on your local disk. Note the three /// after the file: bit
+
+");
+
+        CHOICE: {
+            my $reply = $term->get_reply(
+                            prompt  => loc("Additionals host(s) to add: "),
+                            default => '',
+                        );
+
+            last CHOICE unless $reply =~ /\S/;
+
+            my $href = $self->_parse_host($reply);
+
+            if( $href ) {
+                push @hosts, $href
+                    unless grep {
+                        $href->{'scheme'}   eq $_->{'scheme'}   and
+                        $href->{'host'}     eq $_->{'host'}     and
+                        $href->{'path'}     eq $_->{'path'}
+                    } @hosts;
+
+                last CHOICE if $self->autoreply;
+            } else {
+                print loc("Invalid uri! Please try again!");
+            }
+
+            $self->_view_hosts(@hosts);
+
+            redo CHOICE;
+        }
+
+        DONE: {
+
+            print loc("
+Where would you like to go now?
+
+Please pick one of the following options or Quit when you are done
+
+");
+            my $answer = $term->get_reply(
+                                    prompt  => loc("Where to now?"),
+                                    default => 'Quit',
+                                    choices => [qw|Mirror Custom View Quit|],
+                                );
+
+            if( $answer eq 'View' ) {
+                $self->_view_hosts(@hosts);
+                redo DONE;
+            }
+
+            goto MIRROR if $answer eq 'Mirror';
+            goto CUSTOM if $answer eq 'Custom';
+            goto QUIT   if $answer eq 'Quit';
+        }
+    }
+
+    QUIT: {
+        $conf->set_conf( hosts => \@hosts );
+
+        print loc("
+Your host configuration has been saved
+
+");
+    }
+
+    return 1;
+}
+
+sub _view_hosts {
+    my $self    = shift;
+    my @hosts   = @_;
+
+    print "\n\n";
+
+    if( scalar @hosts ) {
+        my $i = 1;
+        for my $host (@hosts) {
+
+            ### show full path on file uris, otherwise, just show host
+            my $path = join '', (
+                            $host->{'scheme'} eq 'file'
+                                ? ( ($host->{'host'} || '[localhost]'),
+                                    $host->{path} )
+                                : $host->{'host'}
+                        );
+
+            printf "%-40s %30s\n",
+                loc("Selected %1",$host->{'scheme'} . '://' . $path ),
+                loc("%quant(%2,host) selected thus far.", $i);
+            $i++;
+        }
+    } else {
+        print loc("No hosts selected so far.");
+    }
+
+    print "\n\n";
+
+    return 1;
+}
+
+sub _get_mirrored_by {
+    my $self = shift;
+    my $cpan = $self->backend;
+    my $conf = $self->configure_object;
+
+    print loc("
+Now, we are going to fetch the mirror list for first-time configurations.
+This may take a while...
+
+");
+
+    ### use the enew configuratoin ###
+    $cpan->configure_object( $conf );
+
+    load CPANPLUS::Module::Fake;
+    load CPANPLUS::Module::Author::Fake;
+
+    my $mb = CPANPLUS::Module::Fake->new(
+                    module      => $conf->_get_source('hosts'),
+                    path        => '',
+                    package     => $conf->_get_source('hosts'),
+                    author      => CPANPLUS::Module::Author::Fake->new(
+                                        _id => $cpan->_id ),
+                    _id         => $cpan->_id,
+                );
+
+    my $file = $cpan->_fetch(   fetchdir => $conf->get_conf('base'),
+                                module   => $mb );
+
+    return $file if $file;
+    return;
+}
+
+sub _parse_mirrored_by {
+    my $self = shift;
+    my $file = shift;
+
+    -s $file or return;
+
+    my $fh = new FileHandle;
+    $fh->open("$file")
+        or (
+            warn(loc('Could not open file "%1": %2', $file, $!)),
+            return
+        );
+
+    ### slurp the file in ###
+    { local $/; $file = <$fh> }
+
+    ### remove comments ###
+    $file =~ s/#.*$//gm;
+
+    $fh->close;
+
+    ### sample host entry ###
+    #     ftp.sun.ac.za:
+    #       frequency        = "daily"
+    #       dst_ftp          = "ftp://ftp.sun.ac.za/CPAN/CPAN/"
+    #       dst_location     = "Stellenbosch, South Africa, Africa (-26.1992 28.0564)"
+    #       dst_organisation = "University of Stellenbosch"
+    #       dst_timezone     = "+2"
+    #       dst_contact      = "ftpadm@ftp.sun.ac.za"
+    #       dst_src          = "ftp.funet.fi"
+    #
+    #     # dst_dst          = "ftp://ftp.sun.ac.za/CPAN/CPAN/"
+    #     # dst_contact      = "mailto:ftpadm@ftp.sun.ac.za
+    #     # dst_src          = "ftp.funet.fi"
+
+    ### host name as key, rest of the entry as value ###
+    my %hosts = $file =~ m/([a-zA-Z0-9\-\.]+):\s+((?:\w+\s+=\s+".*?"\s+)+)/gs;
+
+    while (my($host,$data) = each %hosts) {
+
+        my $href;
+        map {
+            s/^\s*//;
+            my @a = split /\s*=\s*/;
+            $a[1] =~ s/^"(.+?)"$/$1/g;
+            $href->{ pop @a } = pop @a;
+        } grep /\S/, split /\n/, $data;
+
+        ($href->{city_area}, $href->{country}, $href->{continent},
+            $href->{latitude}, $href->{longitude} ) =
+            $href->{dst_location} =~
+                m/
+                    #Aizu-Wakamatsu, Tohoku-chiho, Fukushima
+                    ^"?(
+                         (?:[^,]+?)\s*         # city
+                         (?:
+                             (?:,\s*[^,]+?)\s* # optional area
+                         )*?                   # some have multiple areas listed
+                     )
+
+                     #Japan
+                     ,\s*([^,]+?)\s*           # country
+
+                     #Asia
+                     ,\s*([^,]+?)\s*           # continent
+
+                     # (37.4333 139.9821)
+                     \((\S+)\s+(\S+?)\)"?$       # (latitude longitude)
+                 /sx;
+
+        ### parse the different hosts, store them in config format ###
+        my @list;
+
+        for my $type (qw[dst_ftp dst_rsync dst_http]) {
+           my $path = $href->{$type};
+           next unless $path =~ /\w/;
+           if ($type eq 'dst_rsync' && $path !~ /^rsync:/) {
+               $path =~ s{::}{/};
+               $path = "rsync://$path/";
+           }
+            my $parts = $self->_parse_host($path);
+            push @list, $parts;
+        }
+
+        $href->{connections}    = \@list;
+        $hosts{$host}           = $href;
+    }
+
+    return \%hosts;
+}
+
+sub _parse_host {
+    my $self = shift;
+    my $host = shift;
+
+    my @parts = $host =~ m|^(\w*)://([^/]*)(/.*)$|s;
+
+    my $href;
+    for my $key (qw[scheme host path]) {
+        $href->{$key} = shift @parts;
+    }
+
+    return if lc($href->{'scheme'}) ne 'file' and !$href->{'host'};
+    return if !$href->{'path'};
+
+    return $href;
+}
+
+## tries to figure out close hosts based on your timezone
+##
+## Currently can only report on unique items for each of zones, countries, and
+## sites.  In the future this will be combined with something else (perhaps a
+## ping?) to narrow down multiple choices.
+##
+## Tries to return the best zone, country, and site for your location.  Any non-
+## unique items will be set to undef instead.
+##
+## (takes hashref, returns array)
+##
+sub _guess_from_timezone {
+    my $self  = shift;
+    my $hosts = shift;
+    my (%zones, %countries, %sites);
+
+    ### autrijus - build time zone table
+    my %freq_weight = (
+        'hourly'        => 2400,
+        '4 times a day' =>  400,
+        '4x daily'      =>  400,
+        'daily'         =>  100,
+        'twice daily'   =>   50,
+        'weekly'        =>   15,
+    );
+
+    while (my ($site, $host) = each %{$hosts}) {
+        my ($zone, $continent, $country, $frequency) =
+            @{$host}{qw/dst_timezone continent country frequency/};
+
+
+        # skip non-well-formed ones
+        next unless $continent and $country and $zone =~ /^[-+]?\d+(?::30)?/;
+        ### fix style
+        chomp $zone;
+        $zone =~ s/:30/.5/;
+        $zone =~ s/^\+//;
+        $zone =~ s/"//g;
+
+        $zones{$zone}{$continent}++;
+        $countries{$zone}{$continent}{$country}++;
+        $sites{$zone}{$continent}{$country}{$site} = $freq_weight{$frequency};
+    }
+
+    use Time::Local;
+    my $offset = ((timegm(localtime) - timegm(gmtime)) / 3600);
+
+    local $_;
+
+    ## pick the entry with most country/site/frequency, one level each;
+    ## note it has to be sorted -- otherwise we're depending on the hash order.
+    ## also, the list context assignment (pick first one) is deliberate.
+
+    my ($continent) = map {
+        (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
+    } $zones{$offset};
+
+    my ($country) = map {
+        (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
+    } $countries{$offset}{$continent};
+
+    my ($site) = map {
+        (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
+    } $sites{$offset}{$continent}{$country};
+
+    return ($continent, $country, $site);
+} # _guess_from_timezone
+
+
+### big big regex, stolen to check if you enter a valid address
+{
+    my $RFC822PAT; # RFC pattern to match for valid email address
+
+    sub _valid_email {
+        my $self = shift;
+        if (!$RFC822PAT) {
+            my $esc        = '\\\\'; my $Period      = '\.'; my $space      = '\040';
+            my $tab         = '\t';  my $OpenBR     = '\[';  my $CloseBR    = '\]';
+            my $OpenParen  = '\(';   my $CloseParen  = '\)'; my $NonASCII   = '\x80-\xff';
+            my $ctrl        = '\000-\037';                   my $CRlist     = '\012\015';
+
+            my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
+            my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
+            my $quoted_pair = qq< $esc [^$NonASCII] >; # an escaped character
+            my $ctext   = qq< [^$esc$NonASCII$CRlist()] >;
+            my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >;
+            my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >;
+            my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >;
+            my $atom_char  = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
+            my $atom = qq< $atom_char+ (?!$atom_char) >;
+            my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >;
+            my $word = qq< (?: $atom | $quoted_str ) >;
+            my $domain_ref  = $atom;
+            my $domain_lit  = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >;
+            my $sub_domain  = qq< (?: $domain_ref | $domain_lit) $X >;
+            my $domain = qq< $sub_domain (?: $Period $X $sub_domain)* >;
+            my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;
+            my $local_part = qq< $word $X (?: $Period $X $word $X )* >;
+            my $addr_spec  = qq< $local_part \@ $X $domain >;
+            my $route_addr = qq[ < $X (?: $route )?  $addr_spec > ];
+            my $phrase_ctrl = '\000-\010\012-\037'; # like ctrl, but without tab
+            my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
+            my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >;
+            $RFC822PAT = qq< $X (?: $addr_spec | $phrase $route_addr) >;
+        }
+
+        return scalar ($_[0] =~ /$RFC822PAT/ox);
+    }
+}
+
+
+
+
+
+
+1;
+
+
+sub _edit {
+    my $self    = shift;
+    my $conf    = $self->configure_object;
+    my $file    = shift || $conf->_config_pm_to_file( $self->config_type );
+    my $editor  = shift || $conf->get_program('editor');
+    my $term    = $self->term;
+
+    unless( $editor ) {
+        print loc("
+I'm sorry, I can't find a suitable editor, so I can't offer you
+post-configuration editing of the config file
+
+");
+        return 1;
+    }
+
+    ### save the thing first, so there's something to edit
+    $self->_save;
+
+    return !system("$editor $file");
+}
+
+sub _save {
+    my $self = shift;
+    my $conf = $self->configure_object;
+    
+    return $conf->save( $self->config_type );
+}    
+
+1;
diff --git a/lib/CPANPLUS/Dist.pm b/lib/CPANPLUS/Dist.pm
new file mode 100644 (file)
index 0000000..50acb48
--- /dev/null
@@ -0,0 +1,505 @@
+package CPANPLUS::Dist;
+
+use strict;
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use Params::Check               qw[check];
+use Module::Load::Conditional   qw[can_load check_install];
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+use Object::Accessor;
+
+local $Params::Check::VERBOSE = 1;
+
+my @methods = qw[status parent];
+for my $key ( @methods ) {
+    no strict 'refs';
+    *{__PACKAGE__."::$key"} = sub {
+        my $self = shift;
+        $self->{$key} = $_[0] if @_;
+        return $self->{$key};
+    }
+}
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Dist
+
+=head1 SYNOPSIS
+
+    my $dist = CPANPLUS::Dist->new(
+                                format  => 'build',
+                                module  => $modobj,
+                            );
+
+=head1 DESCRIPTION
+
+C<CPANPLUS::Dist> is a base class for any type of C<CPANPLUS::Dist::>
+modules.
+
+=head1 ACCESSORS
+
+=over 4
+
+=item parent()
+
+Returns the C<CPANPLUS::Module> object that parented this object.
+
+=item status()
+
+Returns the C<Object::Accessor> object that keeps the status for
+this module.
+
+=back
+
+=head1 STATUS ACCESSORS
+
+All accessors can be accessed as follows:
+    $deb->status->ACCESSOR
+
+=over 4
+
+=item created()
+
+Boolean indicating whether the dist was created successfully.
+Explicitly set to C<0> when failed, so a value of C<undef> may be
+interpreted as C<not yet attempted>.
+
+=item installed()
+
+Boolean indicating whether the dist was installed successfully.
+Explicitly set to C<0> when failed, so a value of C<undef> may be
+interpreted as C<not yet attempted>.
+
+=item uninstalled()
+
+Boolean indicating whether the dist was uninstalled successfully.
+Explicitly set to C<0> when failed, so a value of C<undef> may be
+interpreted as C<not yet attempted>.
+
+=item dist()
+
+The location of the final distribution. This may be a file or
+directory, depending on how your distribution plug in of choice
+works. This will be set upon a successful create.
+
+=cut
+
+=head2 $dist = CPANPLUS::Dist->new( module => MODOBJ, [format => DIST_TYPE] );
+
+Create a new C<CPANPLUS::Dist> object based on the provided C<MODOBJ>.
+The optional argument C<format> is used to indicate what type of dist
+you would like to create (like C<makemaker> for a C<CPANPLUS::Dist::MM>
+object, C<build> for a C<CPANPLUS::Dist::Build> object, and so on ).
+If not provided, will default to the setting as specified by your
+config C<dist_type>.
+
+Returns a C<CPANPLUS::Dist> object on success and false on failure.
+
+=cut
+
+sub new {
+    my $self = shift;
+    my %hash = @_;
+
+    local $Params::Check::ALLOW_UNKNOWN = 1;
+
+    ### first verify we got a module object ###
+    my $mod;
+    my $tmpl = {
+        module  => { required => 1, allow => IS_MODOBJ, store => \$mod },
+    };
+    check( $tmpl, \%hash ) or return;
+
+    ### get the conf object ###
+    my $conf = $mod->parent->configure_object();
+
+    ### figure out what type of dist object to create ###
+    my $format;
+    my $tmpl2 = {
+        format  => {    default => $conf->get_conf('dist_type'),
+                        allow   => [ __PACKAGE__->dist_types ],
+                        store   => \$format  },
+    };
+    check( $tmpl2, \%hash ) or return;
+
+
+    unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) {
+        error(loc("'%1' not found -- you need '%2' version '%3' or higher ".
+                    "to detect plugins", $format, 'Module::Pluggable','2.4'));
+        return;
+    }
+
+    ### bless the object in the child class ###
+    my $obj = bless { parent => $mod }, $format;
+
+    ### check if the format is available in this environment ###
+    if( $conf->_get_build('sanity_check') and not $obj->format_available ) {
+        error( loc( "Format '%1' is not available",$format) );
+        return;
+    }
+
+    ### create a status object ###
+    {   my $acc = Object::Accessor->new;
+        $obj->status($acc);
+
+        ### add minimum supported accessors
+        $acc->mk_accessors( qw[prepared created installed uninstalled 
+                               distdir dist] );
+    }
+
+    ### now initialize it or admit failure
+    unless( $obj->init ) {
+        error(loc("Dist initialization of '%1' failed for '%2'",
+                    $format, $mod->module));
+        return;
+    }
+
+    ### return the object
+    return $obj;
+}
+
+=head2 @dists = CPANPLUS::Dist->dist_types;
+
+Returns a list of the CPANPLUS::Dist::* classes available
+
+=cut
+
+### returns a list of dist_types we support
+### will get overridden by Module::Pluggable if loaded
+### XXX add support for 'plugin' dir in config as well
+{   my $Loaded;
+    my @Dists   = (INSTALLER_MM);
+    my @Ignore  = ();
+
+    ### backdoor method to add more dist types
+    sub _add_dist_types     { my $self = shift; push @Dists,  @_ };
+    
+    ### backdoor method to exclude dist types
+    sub _ignore_dist_types  { my $self = shift; push @Ignore, @_ };
+
+    ### locally add the plugins dir to @INC, so we can find extra plugins
+    #local @INC = @INC, File::Spec->catdir(
+    #                        $conf->get_conf('base'),
+    #                        $conf->_get_build('plugins') );
+
+    ### load any possible plugins
+    sub dist_types {
+
+        if ( !$Loaded++ and check_install(  module  => 'Module::Pluggable',
+                                            version => '2.4')
+        ) {
+            require Module::Pluggable;
+
+            my $only_re = __PACKAGE__ . '::\w+$';
+
+            Module::Pluggable->import(
+                            sub_name    => '_dist_types',
+                            search_path => __PACKAGE__,
+                            only        => qr/$only_re/,
+                            except      => [ INSTALLER_MM, 
+                                             INSTALLER_SAMPLE,
+                                             INSTALLER_BASE,
+                                        ]
+                        );
+            my %ignore = map { $_ => $_ } @Ignore;                        
+                        
+            push @Dists, grep { not $ignore{$_}  } __PACKAGE__->_dist_types;
+        }
+
+        return @Dists;
+    }
+}
+
+=head2 prereq_satisfied( modobj => $modobj, version => $version_spec )
+
+Returns true if this prereq is satisfied.  Returns false if it's not.
+Also issues an error if it seems "unsatisfiable," i.e. if it can't be
+found on CPAN or the latest CPAN version doesn't satisfy it.
+
+=cut
+
+sub prereq_satisfied {
+    my $dist = shift;
+    my $cb   = $dist->parent->parent;
+    my %hash = @_;
+  
+    my($mod,$ver);
+    my $tmpl = {
+        version => { required => 1, store => \$ver },
+        modobj  => { required => 1, store => \$mod, allow => IS_MODOBJ },
+    };
+    
+    check( $tmpl, \%hash ) or return;
+  
+    return 1 if $mod->is_uptodate( version => $ver );
+  
+    if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) {
+
+        error(loc(  
+                "This distribution depends on %1, but the latest version".
+                " of %2 on CPAN (%3) doesn't satisfy the specific version".
+                " dependency (%4). You may have to resolve this dependency ".
+                "manually.", 
+                $mod->module, $mod->module, $mod->version, $ver ));
+  
+    }
+
+    return;
+}
+
+=head2 _resolve_prereqs
+
+Makes sure prerequisites are resolved
+
+XXX Need docs, internal use only
+
+=cut
+
+sub _resolve_prereqs {
+    my $dist = shift;
+    my $self = $dist->parent;
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+    my %hash = @_;
+
+    my ($prereqs, $format, $verbose, $target, $force, $prereq_build);
+    my $tmpl = {
+        ### XXX perhaps this should not be required, since it may not be
+        ### packaged, just installed...
+        ### Let it be empty as well -- that means the $modobj->install
+        ### routine will figure it out, which is fine if we didn't have any
+        ### very specific wishes (it will even detect the favourite
+        ### dist_type).
+        format          => { required => 1, store => \$format,
+                                allow => ['',__PACKAGE__->dist_types], },
+        prereqs         => { required => 1, default => { },
+                                strict_type => 1, store => \$prereqs },
+        verbose         => { default => $conf->get_conf('verbose'),
+                                store => \$verbose },
+        force           => { default => $conf->get_conf('force'),
+                                store => \$force },
+                        ### make sure allow matches with $mod->install's list
+        target          => { default => '', store => \$target,
+                                allow => ['',qw[create ignore install]] },
+        prereq_build    => { default => 0, store => \$prereq_build },
+    };
+
+    check( $tmpl, \%hash ) or return;
+
+    ### so there are no prereqs? then don't even bother
+    return 1 unless keys %$prereqs;
+
+    ### so you didn't provide an explicit target.
+    ### maybe your config can tell us what to do.
+    $target ||= {
+        PREREQ_ASK,     TARGET_INSTALL, # we'll bail out if the user says no
+        PREREQ_BUILD,   TARGET_CREATE,
+        PREREQ_IGNORE,  TARGET_IGNORE,
+        PREREQ_INSTALL, TARGET_INSTALL,
+    }->{ $conf->get_conf('prereqs') } || '';
+    
+    ### XXX BIG NASTY HACK XXX FIXME at some point.
+    ### when installing Bundle::CPANPLUS::Dependencies, we want to
+    ### install all packages matching 'cpanplus' to be installed last,
+    ### as all CPANPLUS' prereqs are being installed as well, but are
+    ### being loaded for bootstrapping purposes. This means CPANPLUS
+    ### can find them, but for example cpanplus::dist::build won't,
+    ### which gets messy FAST. So, here we sort our prereqs only IF
+    ### the parent module is Bundle::CPANPLUS::Dependencies.
+    ### Really, we would wnat some sort of sorted prereq mechanism,
+    ### but Bundle:: doesn't support it, and we flatten everything
+    ### to a hash internally. A sorted hash *might* do the trick if
+    ### we got a transparent implementation.. that would mean we would
+    ### just have to remove the 'sort' here, and all will be well
+    my @sorted_prereqs;
+    
+    ### use regex, could either be a module name, or a package name
+    if( $self->module =~ /^Bundle(::|-)CPANPLUS(::|-)Dependencies/ ) {
+        my (@first, @last);
+        for my $mod ( sort keys %$prereqs ) {
+            $mod =~ /CPANPLUS/
+                ? push @last,  $mod
+                : push @first, $mod;
+        }
+        @sorted_prereqs = (@first, @last);
+    } else {
+        @sorted_prereqs = sort keys %$prereqs;
+    }
+
+    ### first, transfer this key/value pairing into a
+    ### list of module objects + desired versions
+    my @install_me;
+    
+    for my $mod ( @sorted_prereqs ) {
+        my $version = $prereqs->{$mod};
+        my $modobj  = $cb->module_tree($mod);
+
+        #### XXX we ignore the version, and just assume that the latest
+        #### version from cpan will meet your requirements... dodgy =/
+        unless( $modobj ) {
+            error( loc( "No such module '%1' found on CPAN", $mod ) );
+            next;
+        }
+
+        ### it's not uptodate, we need to install it
+        if( !$dist->prereq_satisfied(modobj => $modobj, version => $version)) {
+            msg(loc("Module '%1' requires '%2' version '%3' to be installed ",
+                    $self->module, $modobj->module, $version), $verbose );
+
+            push @install_me, [$modobj, $version];
+
+        ### it's not an MM or Build format, that means it's a package
+        ### manager... we'll need to install it as well, via the PM
+        } elsif ( INSTALL_VIA_PACKAGE_MANAGER->($format) and
+                    !$modobj->package_is_perl_core and
+                    ($target ne TARGET_IGNORE)
+        ) {
+            msg(loc("Module '%1' depends on '%2', may need to build a '%3' ".
+                    "package for it as well", $self->module, $modobj->module,
+                    $format));
+            push @install_me, [$modobj, $version];
+        }
+    }
+
+
+
+    ### so you just want to ignore prereqs? ###
+    if( $target eq TARGET_IGNORE ) {
+
+        ### but you have modules you need to install
+        if( @install_me ) {
+            msg(loc("Ignoring prereqs, this may mean your install will fail"),
+                $verbose);
+            msg(loc("'%1' listed the following dependencies:", $self->module),
+                $verbose);
+
+            for my $aref (@install_me) {
+                my ($mod,$version) = @$aref;
+
+                my $str = sprintf "\t%-35s %8s\n", $mod->module, $version;
+                msg($str,$verbose);
+            }
+
+            return;
+
+        ### ok, no problem, you have all needed prereqs anyway
+        } else {
+            return 1;
+        }
+    }
+
+    my $flag;
+    for my $aref (@install_me) {
+        my($modobj,$version) = @$aref;
+
+        ### another prereq may have already installed this one...
+        ### so dont ask again if the module turns out to be uptodate
+        ### see bug [#11840]
+        ### if either force or prereq_build are given, the prereq
+        ### should be built anyway
+        next if (!$force and !$prereq_build) && 
+                $dist->prereq_satisfied(modobj => $modobj, version => $version);
+
+        ### either we're told to ignore the prereq,
+        ### or the user wants us to ask him
+        if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not
+              $cb->_callbacks->install_prerequisite->($self, $modobj)
+            )
+        ) {
+            msg(loc("Will not install prerequisite '%1' -- Note " .
+                    "that the overall install may fail due to this",
+                    $modobj->module), $verbose);
+            next;
+        }
+
+        ### value set and false -- means failure ###
+        if( defined $modobj->status->installed
+            && !$modobj->status->installed
+        ) {
+            error( loc( "Prerequisite '%1' failed to install before in " .
+                        "this session", $modobj->module ) );
+            $flag++;
+            last;
+        }
+
+        ### part of core?
+        if( $modobj->package_is_perl_core ) {
+            error(loc("Prerequisite '%1' is perl-core (%2) -- not ".
+                      "installing that. Aborting install",
+                      $modobj->module, $modobj->package ) );
+            $flag++;
+            last;
+        }
+
+        ### circular dependency code ###
+        my $pending = $cb->_status->pending_prereqs || {};
+
+        ### recursive dependency ###
+        if ( $pending->{ $modobj->module } ) {
+            error( loc( "Recursive dependency detected (%1) -- skipping",
+                        $modobj->module ) );
+            next;
+        }
+
+        ### register this dependency as pending ###
+        $pending->{ $modobj->module } = $modobj;
+        $cb->_status->pending_prereqs( $pending );
+
+
+        ### call $modobj->install rather than doing
+        ### CPANPLUS::Dist->new and the like ourselves,
+        ### since ->install will take care of fetch &&
+        ### extract as well
+        my $pa = $dist->status->_prepare_args   || {};
+        my $ca = $dist->status->_create_args    || {};
+        my $ia = $dist->status->_install_args   || {};
+
+        unless( $modobj->install(   %$pa, %$ca, %$ia,
+                                    force   => $force,
+                                    verbose => $verbose,
+                                    format  => $format,
+                                    target  => $target )
+        ) {
+            error(loc("Failed to install '%1' as prerequisite " .
+                      "for '%2'", $modobj->module, $self->module ) );
+            $flag++;
+        }
+
+        ### unregister the pending dependency ###
+        $pending->{ $modobj->module } = 0;
+        $cb->_status->pending_prereqs( $pending );
+
+        last if $flag;
+
+        ### don't want us to install? ###
+        if( $target ne TARGET_INSTALL ) {
+            my $dir = $modobj->status->extract
+                        or error(loc("No extraction dir for '%1' found ".
+                                     "-- weird", $modobj->module));
+
+            $modobj->add_to_includepath();
+            
+            next;
+        }
+    }
+
+    ### reset the $prereqs iterator, in case we bailed out early ###
+    keys %$prereqs;
+
+    return 1 unless $flag;
+    return;
+}
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/CPANPLUS/Dist/Base.pm b/lib/CPANPLUS/Dist/Base.pm
new file mode 100644 (file)
index 0000000..2ba0abb
--- /dev/null
@@ -0,0 +1,249 @@
+package CPANPLUS::Dist::Base;
+
+use strict;
+
+use vars    qw[@ISA $VERSION];
+@ISA =      qw[CPANPLUS::Dist];
+$VERSION =  '0.01';
+
+=head1 NAME
+
+CPANPLUS::Dist::Base - Base class for custom distribution classes
+
+=head1 SYNOPSIS
+
+    package CPANPLUS::Dist::MY_IMPLEMENTATION
+
+    use base 'CPANPLUS::Dist::Base';
+
+    sub prepare {
+        my $dist = shift;
+        
+        ### do the 'standard' things
+        $dist->SUPER::prepare( @_ ) or return;
+    
+        ### do MY_IMPLEMENTATION specific things
+        ...
+        
+        ### don't forget to set the status!
+        return $dist->status->prepared( $SUCCESS ? 1 : 0 );
+    }
+
+
+=head1 DESCRIPTION
+
+CPANPLUS::Dist::Base functions as a base class for all custom
+distribution implementations. It does all the mundane work 
+CPANPLUS would have done without a custom distribution, so you
+can override just the parts you need to make your own implementation
+work.
+
+=head1 FLOW
+
+Below is a brief outline when and in which order methods in this
+class are called:
+
+    $Class->format_available;   # can we use this class on this system?
+
+    $dist->init;                # set up custom accessors, etc
+    $dist->prepare;             # find/write meta information
+    $dist->create;              # write the distribution file
+    $dist->install;             # install the distribution file
+    
+    $dist->uninstall;           # remove the distribution (OPTIONAL)
+
+=head1 METHODS
+
+=cut
+
+
+=head2 $bool = $Class->format_available
+
+This method is called when someone requests a module to be installed
+via the superclass. This gives you the opportunity to check if all
+the needed requirements to build and install this distribution have
+been met.
+
+For example, you might need a command line program, or a certain perl
+module installed to do your job. Now is the time to check.
+
+Simply return true if the request can proceed and false if it can not.
+
+The C<CPANPLUS::Dist::Base> implementation always returns true.
+
+=cut 
+
+sub format_available { return 1 }
+
+
+=head2 $bool = $dist->init
+
+This method is called just after the new dist object is set up and
+before the C<prepare> method is called. This is the time to set up
+the object so it can be used with your class. 
+
+For example, you might want to add extra accessors to the C<status>
+object, which you might do as follows:
+
+    $dist->status->mk_accessors( qw[my_implementation_accessor] );
+    
+The C<status> object is implemented as an instance of the 
+C<Object::Accessor> class. Please refer to it's documentation for 
+details.
+    
+Return true if the initialization was successul, and false if it was
+not.
+    
+The C<CPANPLUS::Dist::Base> implementation does not alter your object 
+and always returns true.
+
+=cut
+
+sub init { return 1; }
+
+=head2 $bool = $dist->prepare
+
+This runs the preparation step of your distribution. This step is meant
+to set up the environment so the C<create> step can create the actual
+distribution(file). 
+A C<prepare> call in the standard C<ExtUtils::MakeMaker> distribution 
+would, for example, run C<perl Makefile.PL> to find the dependencies
+for a distribution. For a C<debian> distribution, this is where you 
+would write all the metafiles required for the C<dpkg-*> tools.
+
+The C<CPANPLUS::Dist::Base> implementation simply calls the underlying
+distribution class (Typically C<CPANPLUS::Dist::MM> or 
+C<CPANPLUS::Dist::Build>).
+
+Sets C<< $dist->status->prepared >> to the return value of this function.
+If you override this method, you should make sure to set this value.
+
+=cut
+
+sub prepare { 
+    ### just in case you already did a create call for this module object
+    ### just via a different dist object
+    my $dist        = shift;
+    my $self        = $dist->parent;
+    my $dist_cpan   = $self->status->dist_cpan;
+
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+
+    $dist->status->prepared( $dist_cpan->prepare( @_ ) );
+}
+
+=head2 $bool = $dist->create
+
+This runs the creation step of your distribution. This step is meant
+to follow up on the C<prepare> call, that set up your environment so 
+the C<create> step can create the actual distribution(file). 
+A C<create> call in the standard C<ExtUtils::MakeMaker> distribution 
+would, for example, run C<make> and C<make test> to build and test
+a distribution. For a C<debian> distribution, this is where you 
+would create the actual C<.deb> file using C<dpkg>.
+
+The C<CPANPLUS::Dist::Base> implementation simply calls the underlying
+distribution class (Typically C<CPANPLUS::Dist::MM> or 
+C<CPANPLUS::Dist::Build>).
+
+Sets C<< $dist->status->dist >> to the location of the created 
+distribution.
+If you override this method, you should make sure to set this value.
+
+Sets C<< $dist->status->created >> to the return value of this function.
+If you override this method, you should make sure to set this value.
+
+=cut
+
+sub create { 
+    ### just in case you already did a create call for this module object
+    ### just via a different dist object
+    my $dist        = shift;
+    my $self        = $dist->parent;
+    my $dist_cpan   = $self->status->dist_cpan;
+    $dist           = $self->status->dist   if      $self->status->dist;
+    $self->status->dist( $dist )            unless  $self->status->dist;
+
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+
+    ### make sure to set this variable, if the caller hasn't yet
+    ### just so we have some clue where the dist left off.
+    $dist->status->dist( $dist_cpan->status->distdir )
+        unless defined $dist->status->dist;
+
+    $dist->status->created( $dist_cpan->create( @_ ) );
+}
+
+=head2 $bool = $dist->install
+
+This runs the install step of your distribution. This step is meant
+to follow up on the C<create> call, which prepared a distribution(file)
+to install.
+A C<create> call in the standard C<ExtUtils::MakeMaker> distribution 
+would, for example, run C<make install> to copy the distribution files
+to their final destination. For a C<debian> distribution, this is where 
+you would run C<dpkg --install> on the created C<.deb> file.
+
+The C<CPANPLUS::Dist::Base> implementation simply calls the underlying
+distribution class (Typically C<CPANPLUS::Dist::MM> or 
+C<CPANPLUS::Dist::Build>).
+
+Sets C<< $dist->status->installed >> to the return value of this function.
+If you override this method, you should make sure to set this value.
+
+=cut
+
+sub install { 
+    ### just in case you already did a create call for this module object
+    ### just via a different dist object
+    my $dist        = shift;
+    my $self        = $dist->parent;
+    my $dist_cpan   = $self->status->dist_cpan;    
+
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+
+    $dist->status->installed( $dist_cpan->install( @_ ) );
+}
+
+=head2 $bool = $dist->uninstall
+
+This runs the uninstall step of your distribution. This step is meant
+to remove the distribution from the file system. 
+A C<uninstall> call in the standard C<ExtUtils::MakeMaker> distribution 
+would, for example, run C<make uninstall> to remove the distribution 
+files the file system. For a C<debian> distribution, this is where you 
+would run C<dpkg --uninstall PACKAGE>.
+
+The C<CPANPLUS::Dist::Base> implementation simply calls the underlying
+distribution class (Typically C<CPANPLUS::Dist::MM> or 
+C<CPANPLUS::Dist::Build>).
+
+Sets C<< $dist->status->uninstalled >> to the return value of this function.
+If you override this method, you should make sure to set this value.
+
+=cut
+
+sub uninstall { 
+    ### just in case you already did a create call for this module object
+    ### just via a different dist object
+    my $dist        = shift;
+    my $self        = $dist->parent;
+    my $dist_cpan   = $self->status->dist_cpan;    
+
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+
+    $dist->status->uninstalled( $dist_cpan->uninstall( @_ ) );
+}
+
+1;              
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/CPANPLUS/Dist/MM.pm b/lib/CPANPLUS/Dist/MM.pm
new file mode 100644 (file)
index 0000000..f61cfc8
--- /dev/null
@@ -0,0 +1,955 @@
+package CPANPLUS::Dist::MM;
+
+use strict;
+use vars    qw[@ISA $STATUS];
+@ISA =      qw[CPANPLUS::Dist];
+
+
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Internals::Constants::Report;
+use CPANPLUS::Error;
+use FileHandle;
+use Cwd;
+
+use IPC::Cmd                    qw[run];
+use Params::Check               qw[check];
+use File::Basename              qw[dirname];
+use Module::Load::Conditional   qw[can_load check_install];
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+
+local $Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Dist::MM
+
+=head1 SYNOPSIS
+
+    my $mm = CPANPLUS::Dist->new( 
+                                format  => 'makemaker',
+                                module  => $modobj, 
+                            );
+    $mm->create;        # runs make && make test
+    $mm->install;       # runs make install
+
+    
+=head1 DESCRIPTION
+
+C<CPANPLUS::Dist::MM> is a distribution class for MakeMaker related
+modules.
+Using this package, you can create, install and uninstall perl 
+modules. It inherits from C<CPANPLUS::Dist>.
+
+=head1 ACCESSORS
+
+=over 4
+
+=item parent()
+
+Returns the C<CPANPLUS::Module> object that parented this object.
+
+=item status()
+
+Returns the C<Object::Accessor> object that keeps the status for
+this module.
+
+=back
+
+=head1 STATUS ACCESSORS 
+
+All accessors can be accessed as follows:
+    $mm->status->ACCESSOR
+
+=over 4
+
+=item makefile ()
+
+Location of the Makefile (or Build file). 
+Set to 0 explicitly if something went wrong.
+
+=item make ()
+
+BOOL indicating if the C<make> (or C<Build>) command was successful.
+
+=item test ()
+
+BOOL indicating if the C<make test> (or C<Build test>) command was 
+successful.
+
+=item prepared ()
+
+BOOL indicating if the C<prepare> call exited succesfully
+This gets set after C<perl Makefile.PL>
+
+=item distdir ()
+
+Full path to the directory in which the C<prepare> call took place,
+set after a call to C<prepare>. 
+
+=item created ()
+
+BOOL indicating if the C<create> call exited succesfully. This gets
+set after C<make> and C<make test>.
+
+=item installed ()
+
+BOOL indicating if the module was installed. This gets set after
+C<make install> (or C<Build install>) exits successfully.
+
+=item uninstalled ()
+
+BOOL indicating if the module was uninstalled properly.
+
+=item _create_args ()
+
+Storage of the arguments passed to C<create> for this object. Used
+for recursive calls when satisfying prerequisites.
+
+=item _install_args ()
+
+Storage of the arguments passed to C<install> for this object. Used
+for recursive calls when satisfying prerequisites.
+
+=back
+
+=cut
+
+=head1 METHODS
+
+=head2 $bool = $dist->format_available();
+
+Returns a boolean indicating whether or not you can use this package
+to create and install modules in your environment.
+
+=cut
+
+### check if the format is available ###
+sub format_available {
+    my $dist = shift;
+  
+    ### we might be called as $class->format_available =/
+    require CPANPLUS::Internals;
+    my $cb   = CPANPLUS::Internals->_retrieve_id( 
+                    CPANPLUS::Internals->_last_id );
+    my $conf = $cb->configure_object;
+  
+    my $mod = "ExtUtils::MakeMaker";
+    unless( can_load( modules => { $mod => 0.0 } ) ) {
+        error( loc( "You do not have '%1' -- '%2' not available",
+                    $mod, __PACKAGE__ ) ); 
+        return;
+    }
+    
+    for my $pgm ( qw[make perlwrapper] ) {
+        unless( $conf->get_program( $pgm ) ) { 
+            error(loc(
+                "You do not have '%1' in your path -- '%2' not available\n" .
+                "Please check your config entry for '%1'", 
+                $pgm, __PACKAGE__ , $pgm
+            )); 
+            return;
+        }
+    }
+
+    return 1;     
+}
+
+=pod $bool = $dist->init();
+
+Sets up the C<CPANPLUS::Dist::MM> object for use. 
+Effectively creates all the needed status accessors.
+
+Called automatically whenever you create a new C<CPANPLUS::Dist> object.
+
+=cut
+
+sub init {
+    my $dist    = shift;
+    my $status  = $dist->status;
+   
+    $status->mk_accessors(qw[makefile make test created installed uninstalled
+                             bin_make _prepare_args _create_args _install_args]
+                        );
+    
+    return 1;
+}    
+
+=pod $bool = $dist->prepare([perl => '/path/to/perl', makemakerflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL])
+
+C<prepare> preps a distribution for installation. This means it will 
+run C<perl Makefile.PL> and determine what prerequisites this distribution
+declared.
+
+If you set C<force> to true, it will go over all the stages of the 
+C<prepare> process again, ignoring any previously cached results. 
+
+When running C<perl Makefile.PL>, the environment variable
+C<PERL5_CPANPLUS_IS_EXECUTING> will be set to the full path of the
+C<Makefile.PL> that is being executed. This enables any code inside
+the C<Makefile.PL> to know that it is being installed via CPANPLUS.
+
+Returns true on success and false on failure.
+
+You may then call C<< $dist->create >> on the object to create the
+installable files.
+
+=cut
+
+sub prepare {
+    ### just in case you already did a create call for this module object
+    ### just via a different dist object
+    my $dist = shift;
+    my $self = $dist->parent;
+    
+    ### we're also the cpan_dist, since we don't need to have anything
+    ### prepared 
+    $dist    = $self->status->dist_cpan if      $self->status->dist_cpan;     
+    $self->status->dist_cpan( $dist )   unless  $self->status->dist_cpan;    
+
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+    my %hash = @_;
+
+    my $dir;
+    unless( $dir = $self->status->extract ) {
+        error( loc( "No dir found to operate on!" ) );
+        return;
+    }
+$DB::single = 1; 
+    my $args;
+    my( $force, $verbose, $perl, $mmflags );
+    {   local $Params::Check::ALLOW_UNKNOWN = 1;
+        my $tmpl = {
+            perl            => {    default => $^X, store => \$perl },
+            makemakerflags  => {    default =>
+                                        $conf->get_conf('makemakerflags'),
+                                    store => \$mmflags },                 
+            force           => {    default => $conf->get_conf('force'), 
+                                    store   => \$force },
+            verbose         => {    default => $conf->get_conf('verbose'), 
+                                    store   => \$verbose },
+        };                                            
+
+        $args = check( $tmpl, \%hash ) or return;
+    }
+    
+    ### maybe we already ran a create on this object? ###
+    return 1 if $dist->status->prepared && !$force;
+        
+    ### store the arguments, so ->install can use them in recursive loops ###
+    $dist->status->_prepare_args( $args );
+    
+    ### chdir to work directory ###
+    my $orig = cwd();
+    unless( $cb->_chdir( dir => $dir ) ) {
+        error( loc( "Could not chdir to build directory '%1'", $dir ) );
+        return;
+    }
+    
+    my $fail; 
+    RUN: {
+        ### don't run 'perl makefile.pl' again if there's a makefile already 
+        if( -e MAKEFILE->() && (-M MAKEFILE->() < -M $dir) && !$force ) {
+            msg(loc("'%1' already exists, not running '%2 %3' again ".
+                    " unless you force",
+                    MAKEFILE->(), $perl, MAKEFILE_PL->() ), $verbose );
+            
+        } else {
+            unless( -e MAKEFILE_PL->() ) {
+                msg(loc("No '%1' found - attempting to generate one",
+                        MAKEFILE_PL->() ), $verbose );
+                        
+                $dist->write_makefile_pl( 
+                            verbose => $verbose, 
+                            force   => $force 
+                        );
+                
+                ### bail out if there's no makefile.pl ###
+                unless( -e MAKEFILE_PL->() ) {
+                    error( loc( "Could not find '%1' - cannot continue", 
+                                MAKEFILE_PL->() ) );
+        
+                    ### mark that we screwed up ###
+                    $dist->status->makefile(0);
+                    $fail++; last RUN;
+                }
+            }    
+    
+            ### you can turn off running this verbose by changing
+            ### the config setting below, although it is really not
+            ### recommended
+            my $run_verbose = $verbose || 
+                              $conf->get_conf('allow_build_interactivity') ||
+                              0;
+    
+            ### this makes MakeMaker use defaults if possible, according
+            ### to schwern. See ticket 8047 for details.
+            local $ENV{PERL_MM_USE_DEFAULT} = 1 unless $run_verbose; 
+    
+            ### turn off our PERL5OPT so no modules from CPANPLUS::inc get
+            ### included in the makefile.pl -- it should build without
+            ### also, modules that run in taint mode break if we leave
+            ### our code ref in perl5opt
+            ### XXX we've removed the ENV settings from cp::inc, so only need
+            ### to reset the @INC
+            #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt || ''; 
+    
+            ### make sure it's a string, so that mmflags that have more than
+            ### one key value pair are passed as is, rather than as:
+            ### perl Makefile.PL "key=val key=>val"
+            
+            
+            #### XXX this needs to be the absolute path to the Makefile.PL
+            ### since cpanp-run-perl uses 'do' to execute the file, and do()
+            ### checks your @INC.. so, if there's _another_ makefile.pl in
+            ### your @INC, it will execute that one...
+            my $makefile_pl = $cb->_safe_path( path => MAKEFILE_PL->( $dir ) );
+            
+            ### setting autoflush to true fixes issue from rt #8047
+            ### XXX this means that we need to keep the path to CPANPLUS
+            ### in @INC, stopping us from resolving dependencies on CPANPLUS
+            ### at bootstrap time properly.
+
+            ### XXX this fails under ipc::run due to the extra quotes,
+            ### but it works in ipc::open3. however, ipc::open3 doesn't work
+            ### on win32/cygwin. XXX TODO get a windows box and sort this out
+            # my $cmd =  qq[$perl -MEnglish -le ] . 
+            #            QUOTE_PERL_ONE_LINER->(
+            #                qq[\$OUTPUT_AUTOFLUSH++,do(q($makefile_pl))]
+            #            ) 
+            #            . $mmflags;
+
+            # my $flush = OPT_AUTOFLUSH;
+            # my $cmd     = "$perl $flush $makefile_pl $mmflags";
+
+            my $run_perl    = $conf->get_program('perlwrapper');
+            my $cmd         = "$perl $run_perl $makefile_pl $mmflags";
+
+            ### set ENV var to tell underlying code this is what we're
+            ### executing.
+            my $captured; 
+            my $rv = do {
+                my $env = ENV_CPANPLUS_IS_EXECUTING;
+                local $ENV{$env} = $makefile_pl;
+                scalar run( command => $cmd,
+                            buffer  => \$captured,
+                            verbose => $run_verbose, # may be interactive   
+                        );
+            };
+    
+            unless( $rv ) {
+                error( loc( "Could not run '%1 %2': %3 -- cannot continue",
+                            $perl, MAKEFILE_PL->(), $captured ) );
+                
+                $dist->status->makefile(0);
+                $fail++; last RUN;
+            }
+
+            ### put the output on the stack, don't print it
+            msg( $captured, 0 );
+        }
+        
+        ### so, nasty feature in Module::Build, that when a Makefile.PL
+        ### is a disguised Build.PL, it generates a Build file, not a
+        ### Makefile. this breaks everything :( see rt bug #19741
+        if( not -e MAKEFILE->( $dir ) and -e BUILD_PL->( $dir ) ) {
+            error(loc(
+                    "We just ran '%1' without errors, but no '%2' is ".
+                    "present. However, there is a '%3' file, so this may ".
+                    "be related to bug #19741 in %4, which describes a ".
+                    "fake '%5' which generates a '%6' file instead of a '%7'. ".
+                    "You could try to work around this issue by setting '%8' ".
+                    "to false and trying again. This will attempt to use the ".
+                    "'%9' instead.",
+                    "$^X ".MAKEFILE_PL->(), MAKEFILE->(), BUILD_PL->(),
+                    'Module::Build', MAKEFILE_PL->(), 'Build', MAKEFILE->(),
+                    'prefer_makefile', BUILD_PL->()
+            ));           
+            
+            $fail++, last RUN;
+        }
+        
+        ### if we got here, we managed to make a 'makefile' ###
+        $dist->status->makefile( MAKEFILE->($dir) );               
+        
+        ### start resolving prereqs ###
+        my $prereqs = $self->status->prereqs;
+        
+        ### a hashref of prereqs on success, undef on failure ###
+        $prereqs    ||= $dist->_find_prereqs( 
+                                    verbose => $verbose,
+                                    file    => $dist->status->makefile 
+                                );
+        
+        unless( $prereqs ) {
+            error( loc( "Unable to scan '%1' for prereqs", 
+                        $dist->status->makefile ) );
+
+            $fail++; last RUN;
+        }
+    }
+   
+       unless( $cb->_chdir( dir => $orig ) ) {
+        error( loc( "Could not chdir back to start dir '%1'", $orig ) );
+    }   
+   
+    ### save where we wrote this stuff -- same as extract dir in normal
+    ### installer circumstances
+    $dist->status->distdir( $self->status->extract );
+   
+    return $dist->status->prepared( $fail ? 0 : 1);
+}
+
+=pod
+
+=head2 $href = $dist->_find_prereqs( file => '/path/to/Makefile', [verbose => BOOL])
+
+Parses a C<Makefile> for C<PREREQ_PM> entries and distills from that
+any prerequisites mentioned in the C<Makefile>
+
+Returns a hash with module-version pairs on success and false on
+failure.
+
+=cut
+
+sub _find_prereqs {
+    my $dist = shift;
+    my $self = $dist->parent;
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+    my %hash = @_;
+
+    my ($verbose, $file);
+    my $tmpl = {
+        verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+        file    => { required => 1, allow => FILE_READABLE, store => \$file },
+    };
+    
+    my $args = check( $tmpl, \%hash ) or return;      
+    
+    my $fh = FileHandle->new();
+    unless( $fh->open( $file ) ) {
+        error( loc( "Cannot open '%1': %2", $file, $! ) );
+        return;
+    }
+    
+    my %p;
+    while( <$fh> ) {
+        my ($found) = m|^[\#]\s+PREREQ_PM\s+=>\s+(.+)|;         
+        
+        next unless $found;
+        
+        while( $found =~ m/(?:\s)([\w\:]+)=>(?:q\[(.*?)\],?|undef)/g ) {
+            if( defined $p{$1} ) {
+                msg(loc("Warning: PREREQ_PM mentions '%1' more than once. " .
+                        "Last mention wins.", $1 ), $verbose );
+            }
+            
+            $p{$1} = $cb->_version_to_number(version => $2);                  
+        }
+        last;
+    }
+
+    my $href = $cb->_callbacks->filter_prereqs->( $cb, \%p );
+
+    $self->status->prereqs( $href );
+    
+    ### just to make sure it's not the same reference ###
+    return { %$href };                              
+}     
+
+=pod
+
+=head2 $bool = $dist->create([perl => '/path/to/perl', make => '/path/to/make', makeflags => 'EXTRA=FLAGS', prereq_target => TARGET, skiptest => BOOL, force => BOOL, verbose => BOOL])
+
+C<create> creates the files necessary for installation. This means 
+it will run C<make> and C<make test>.  This will also scan for and 
+attempt to satisfy any prerequisites the module may have. 
+
+If you set C<skiptest> to true, it will skip the C<make test> stage.
+If you set C<force> to true, it will go over all the stages of the 
+C<make> process again, ignoring any previously cached results. It 
+will also ignore a bad return value from C<make test> and still allow 
+the operation to return true.
+
+Returns true on success and false on failure.
+
+You may then call C<< $dist->install >> on the object to actually
+install it.
+
+=cut
+
+sub create {
+    ### just in case you already did a create call for this module object
+    ### just via a different dist object
+    my $dist = shift;
+    my $self = $dist->parent;
+    
+    ### we're also the cpan_dist, since we don't need to have anything
+    ### prepared 
+    $dist    = $self->status->dist_cpan if      $self->status->dist_cpan;     
+    $self->status->dist_cpan( $dist )   unless  $self->status->dist_cpan;    
+
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+    my %hash = @_;
+
+    my $dir;
+    unless( $dir = $self->status->extract ) {
+        error( loc( "No dir found to operate on!" ) );
+        return;
+    }
+    
+    my $args;
+    my( $force, $verbose, $make, $makeflags, $skiptest, $prereq_target, $perl, 
+        $mmflags, $prereq_format, $prereq_build);
+    {   local $Params::Check::ALLOW_UNKNOWN = 1;
+        my $tmpl = {
+            perl            => {    default => $^X, store => \$perl },
+            force           => {    default => $conf->get_conf('force'), 
+                                    store   => \$force },
+            verbose         => {    default => $conf->get_conf('verbose'), 
+                                    store   => \$verbose },
+            make            => {    default => $conf->get_program('make'), 
+                                    store   => \$make },
+            makeflags       => {    default => $conf->get_conf('makeflags'), 
+                                    store   => \$makeflags },
+            skiptest        => {    default => $conf->get_conf('skiptest'), 
+                                    store   => \$skiptest },
+            prereq_target   => {    default => '', store => \$prereq_target }, 
+            ### don't set the default prereq format to 'makemaker' -- wrong!
+            prereq_format   => {    #default => $self->status->installer_type,
+                                    default => '',
+                                    store   => \$prereq_format },   
+            prereq_build    => {    default => 0, store => \$prereq_build },                                    
+        };                                            
+
+        $args = check( $tmpl, \%hash ) or return;
+    }
+    
+    ### maybe we already ran a create on this object? ###
+    return 1 if $dist->status->created && !$force;
+        
+    ### store the arguments, so ->install can use them in recursive loops ###
+    $dist->status->_create_args( $args );
+    
+    unless( $dist->status->prepared ) {
+        error( loc( "You have not successfully prepared a '%2' distribution ".
+                    "yet -- cannot create yet", __PACKAGE__ ) );
+        return;
+    }
+    
+    
+    ### chdir to work directory ###
+    my $orig = cwd();
+    unless( $cb->_chdir( dir => $dir ) ) {
+        error( loc( "Could not chdir to build directory '%1'", $dir ) );
+        return;
+    }
+    
+    my $fail; my $prereq_fail; my $test_fail;
+    RUN: {
+        ### this will set the directory back to the start
+        ### dir, so we must chdir /again/           
+        my $ok = $dist->_resolve_prereqs(
+                            format          => $prereq_format,
+                            verbose         => $verbose,
+                            prereqs         => $self->status->prereqs,
+                            target          => $prereq_target,
+                            force           => $force,
+                            prereq_build    => $prereq_build,
+                    );
+        
+        unless( $cb->_chdir( dir => $dir ) ) {
+            error( loc( "Could not chdir to build directory '%1'", $dir ) );
+            return;
+        }       
+                  
+        unless( $ok ) {
+       
+            #### use $dist->flush to reset the cache ###
+            error( loc( "Unable to satisfy prerequisites for '%1' " .
+                        "-- aborting install", $self->module ) );    
+            $dist->status->make(0);
+            $fail++; $prereq_fail++;
+            last RUN;
+        } 
+        ### end of prereq resolving ###    
+        
+        my $captured;
+        
+        ### 'make' section ###    
+        if( -d BLIB->($dir) && (-M BLIB->($dir) < -M $dir) && !$force ) {
+            msg(loc("Already ran '%1' for this module [%2] -- " .
+                    "not running again unless you force", 
+                    $make, $self->module ), $verbose );
+        } else {
+            unless(scalar run(  command => [$make, $makeflags],
+                                buffer  => \$captured,
+                                verbose => $verbose ) 
+            ) {
+                error( loc( "MAKE failed: %1 %2", $!, $captured ) );
+                $dist->status->make(0);
+                $fail++; last RUN;
+            }
+            
+            ### put the output on the stack, don't print it
+            msg( $captured, 0 );
+
+            $dist->status->make(1);
+
+            ### add this directory to your lib ###
+            $self->add_to_includepath();
+            
+            ### dont bail out here, there's a conditional later on
+            #last RUN if $skiptest;
+        }
+        
+        ### 'make test' section ###                                           
+        unless( $skiptest ) {
+
+            ### turn off our PERL5OPT so no modules from CPANPLUS::inc get
+            ### included in make test -- it should build without
+            ### also, modules that run in taint mode break if we leave
+            ### our code ref in perl5opt
+            ### XXX CPANPLUS::inc functionality is now obsolete.
+            #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt || '';
+
+            ### you can turn off running this verbose by changing
+            ### the config setting below, although it is really not 
+            ### recommended
+            my $run_verbose =   
+                        $verbose || 
+                        $conf->get_conf('allow_build_interactivity') ||
+                        0;
+
+            ### XXX need to add makeflags here too? 
+            ### yes, but they should really be split out -- see bug #4143
+            if( scalar run( 
+                        command => [$make, 'test', $makeflags],
+                        buffer  => \$captured,
+                        verbose => $run_verbose,
+            ) ) {
+                ### tests might pass because it doesn't have any tests defined
+                ### log this occasion non-verbosely, so our test reporter can
+                ### pick up on this
+                if ( NO_TESTS_DEFINED->( $captured ) ) {
+                    msg( NO_TESTS_DEFINED->( $captured ), 0 )
+                } else {
+                    msg( loc( "MAKE TEST passed: %2", $captured ), $verbose );
+                }
+            
+                $dist->status->test(1);
+            } else {
+                error( loc( "MAKE TEST failed: %1 %2", $!, $captured ) );
+            
+                ### send out error report here? or do so at a higher level?
+                ### --higher level --kane.
+                $dist->status->test(0);
+               
+                ### mark specifically *test* failure.. so we dont
+                ### send success on force...
+                $test_fail++;
+                
+                unless( $force ) {
+                    $fail++; last RUN;     
+                }
+            }
+        }
+    } #</RUN>
+      
+    unless( $cb->_chdir( dir => $orig ) ) {
+        error( loc( "Could not chdir back to start dir '%1'", $orig ) );
+    }  
+    
+    ### send out test report?
+    ### only do so if the failure is this module, not its prereq
+    if( $conf->get_conf('cpantest') and not $prereq_fail) {
+        $cb->_send_report( 
+            module  => $self,
+            failed  => $test_fail || $fail,
+            buffer  => CPANPLUS::Error->stack_as_string,
+            verbose => $verbose,
+            force   => $force,
+        ) or error(loc("Failed to send test report for '%1'",
+                    $self->module ) );
+    }            
+            
+    return $dist->status->created( $fail ? 0 : 1);
+} 
+
+=pod
+
+=head2 $bool = $dist->install([make => '/path/to/make',  makemakerflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL])
+
+C<install> runs the following command:
+    make install
+
+Returns true on success, false on failure.    
+
+=cut
+
+sub install {
+
+    ### just in case you did the create with ANOTHER dist object linked
+    ### to the same module object
+    my $dist = shift();
+    my $self = $dist->parent;
+    $dist    = $self->status->dist_cpan if $self->status->dist_cpan;       
+   
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+    my %hash = @_;
+    
+    
+    unless( $dist->status->created ) {
+        error(loc("You have not successfully created a '%2' distribution yet " .
+                  "-- cannot install yet", __PACKAGE__ ));
+        return;
+    }
+    my $dir;
+    unless( $dir = $self->status->extract ) {
+        error( loc( "No dir found to operate on!" ) );
+        return;
+    }
+    
+    my $args;
+    my($force,$verbose,$make,$makeflags);
+    {   local $Params::Check::ALLOW_UNKNOWN = 1;
+        my $tmpl = {
+            force       => {    default => $conf->get_conf('force'), 
+                                store   => \$force },
+            verbose     => {    default => $conf->get_conf('verbose'), 
+                                store   => \$verbose },
+            make        => {    default => $conf->get_program('make'), 
+                                store   => \$make },
+            makeflags   => {    default => $conf->get_conf('makeflags'), 
+                                store   => \$makeflags },
+        };      
+    
+        $args = check( $tmpl, \%hash ) or return;
+    }
+
+    ### value set and false -- means failure ###
+    if( defined $self->status->installed && 
+        !$self->status->installed && !$force 
+    ) {
+        error( loc( "Module '%1' has failed to install before this session " .
+                    "-- aborting install", $self->module ) );
+        return;
+    }
+
+            
+    $dist->status->_install_args( $args );
+    
+    my $orig = cwd();
+    unless( $cb->_chdir( dir => $dir ) ) {
+        error( loc( "Could not chdir to build directory '%1'", $dir ) );
+        return;
+    }
+    
+    my $fail; my $captured;
+    
+    ### 'make install' section ###
+    ### XXX need makeflags here too? 
+    ### yes, but they should really be split out.. see bug #4143
+    my $cmd     = [$make, 'install', $makeflags];
+    my $sudo    = $conf->get_program('sudo');
+    unshift @$cmd, $sudo if $sudo and $>;
+
+    $cb->flush('lib');
+    unless(scalar run(  command => $cmd,
+                        verbose => $verbose,
+                        buffer  => \$captured,
+    ) ) {                   
+        error( loc( "MAKE INSTALL failed: %1 %2", $!, $captured ) );
+        $fail++; 
+    }       
+
+    ### put the output on the stack, don't print it
+    msg( $captured, 0 );
+    
+    unless( $cb->_chdir( dir => $orig ) ) {
+        error( loc( "Could not chdir back to start dir '%1'", $orig ) );
+    }   
+    
+    return $dist->status->installed( $fail ? 0 : 1 );
+    
+}
+
+=pod
+
+=head2 $bool = $dist->write_makefile_pl([force => BOOL, verbose => BOOL])
+
+This routine can write a C<Makefile.PL> from the information in a 
+module object. It is used to write a C<Makefile.PL> when the original
+author forgot it (!!).
+
+Returns 1 on success and false on failure.
+
+The file gets written to the directory the module's been extracted 
+to.
+
+=cut
+
+sub write_makefile_pl {
+    ### just in case you already did a call for this module object
+    ### just via a different dist object
+    my $dist = shift;
+    my $self = $dist->parent;
+    $dist    = $self->status->dist_cpan if      $self->status->dist_cpan;     
+    $self->status->dist_cpan( $dist )   unless  $self->status->dist_cpan;    
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+    my %hash = @_;
+
+    my $dir;
+    unless( $dir = $self->status->extract ) {
+        error( loc( "No dir found to operate on!" ) );
+        return;
+    }
+    
+    my ($force, $verbose);
+    my $tmpl = {
+        force           => {    default => $conf->get_conf('force'),   
+                                store => \$force },
+        verbose         => {    default => $conf->get_conf('verbose'), 
+                                store => \$verbose },   
+    };                                          
+
+    my $args = check( $tmpl, \%hash ) or return;    
+    
+    my $file = MAKEFILE_PL->($dir);
+    if( -s $file && !$force ) {
+        msg(loc("Already created '%1' - not doing so again without force", 
+                $file ), $verbose );
+        return 1;
+    }     
+
+    ### due to a bug with AS perl 5.8.4 built 810 (and maybe others)
+    ### opening files with content in them already does nasty things;
+    ### seek to pos 0 and then print, but not truncating the file
+    ### bug reported to activestate on 19 sep 2004:
+    ### http://bugs.activestate.com/show_bug.cgi?id=34051
+    unlink $file if $force;
+
+    my $fh = new FileHandle;
+    unless( $fh->open( ">$file" ) ) {
+        error( loc( "Could not create file '%1': %2", $file, $! ) );
+        return;
+    }
+    
+    my $mf      = MAKEFILE_PL->();
+    my $name    = $self->module;
+    my $version = $self->version;
+    my $author  = $self->author->author;
+    my $href    = $self->status->prereqs;
+    my $prereqs = join ",\n", map { 
+                                (' ' x 25) . "'$_'\t=> '$href->{$_}'" 
+                            } keys %$href;  
+    $prereqs ||= ''; # just in case there are none;                         
+                             
+    print $fh qq|
+    ### Auto-generated $mf by CPANPLUS ###
+    
+    use ExtUtils::MakeMaker;
+    
+    WriteMakefile(
+        NAME        => '$name',
+        VERSION     => '$version',
+        AUTHOR      => '$author',
+        PREREQ_PM   => {
+$prereqs                       
+                    },
+    );
+    \n|;   
+    
+    $fh->close;
+    return 1;
+}                         
+        
+sub dist_dir {
+    ### just in case you already did a call for this module object
+    ### just via a different dist object
+    my $dist = shift;
+    my $self = $dist->parent;
+    $dist    = $self->status->dist_cpan if      $self->status->dist_cpan;     
+    $self->status->dist_cpan( $dist )   unless  $self->status->dist_cpan;    
+    my $cb   = $self->parent;
+    my $conf = $cb->configure_object;
+    my %hash = @_;
+    
+    my $make; my $verbose;
+    {   local $Params::Check::ALLOW_UNKNOWN = 1;
+        my $tmpl = {
+            make    => {    default => $conf->get_program('make'),
+                                    store => \$make },                 
+            verbose => {    default => $conf->get_conf('verbose'), 
+                                    store   => \$verbose },
+        };  
+    
+        check( $tmpl, \%hash ) or return;    
+    }
+
+
+    my $dir;
+    unless( $dir = $self->status->extract ) {
+        error( loc( "No dir found to operate on!" ) );
+        return;
+    }
+    
+    ### chdir to work directory ###
+    my $orig = cwd();
+    unless( $cb->_chdir( dir => $dir ) ) {
+        error( loc( "Could not chdir to build directory '%1'", $dir ) );
+        return;
+    }
+
+    my $fail; my $distdir;
+    TRY: {    
+        $dist->prepare( @_ ) or (++$fail, last TRY);
+
+
+        my $captured;             
+            unless(scalar run(  command => [$make, 'distdir'],
+                            buffer  => \$captured,
+                            verbose => $verbose ) 
+        ) {
+            error( loc( "MAKE DISTDIR failed: %1 %2", $!, $captured ) );
+            ++$fail, last TRY;
+        }
+
+        ### /path/to/Foo-Bar-1.2/Foo-Bar-1.2
+        $distdir = File::Spec->catdir( $dir, $self->package_name . '-' .
+                                                $self->package_version );
+
+        unless( -d $distdir ) {
+            error(loc("Do not know where '%1' got created", 'distdir'));
+            ++$fail, last TRY;
+        }
+    }
+
+    unless( $cb->_chdir( dir => $orig ) ) {
+        error( loc( "Could not chdir to start directory '%1'", $orig ) );
+        return;
+    }
+
+    return if $fail;
+    return $distdir;
+}    
+
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/CPANPLUS/Dist/Sample.pm b/lib/CPANPLUS/Dist/Sample.pm
new file mode 100644 (file)
index 0000000..0b09392
--- /dev/null
@@ -0,0 +1,16 @@
+package CPANPLUS::Dist::Sample;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Dist::Sample -- Sample code to create your own Dist::* plugin
+
+=head1 Description.
+
+This document is B<Obsolete>. Please read the documentation and code
+in C<CPANPLUS::Dist::Base>.
+
+=cut
+
+1;
diff --git a/lib/CPANPLUS/Error.pm b/lib/CPANPLUS/Error.pm
new file mode 100644 (file)
index 0000000..38710a8
--- /dev/null
@@ -0,0 +1,201 @@
+package CPANPLUS::Error;
+
+use strict;
+
+use Log::Message private => 0;;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Error
+
+=head1 SYNOPSIS
+
+    use CPANPLUS::Error qw[cp_msg cp_error];
+
+=head1 DESCRIPTION
+
+This module provides the error handling code for the CPANPLUS
+libraries, and is mainly intended for internal use.
+
+=head1 FUNCTIONS
+
+=head2 cp_msg("message string" [,VERBOSE])
+
+Records a message on the stack, and prints it to C<STDOUT> (or actually
+C<$MSG_FH>, see the C<GLOBAL VARIABLES> section below), if the
+C<VERBOSE> option is true.
+The C<VERBOSE> option defaults to false.
+
+=head2 msg()
+
+An alias for C<cp_msg>.
+
+=head2 cp_error("error string" [,VERBOSE])
+
+Records an error on the stack, and prints it to C<STDERR> (or actually
+C<$ERROR_FH>, see the C<GLOBAL VARIABLES> sections below), if the
+C<VERBOSE> option is true.
+The C<VERBOSE> options defaults to true.
+
+=head2 error()
+
+An alias for C<cp_error>.
+
+=head1 CLASS METHODS
+
+=head2 CPANPLUS::Error->stack()
+
+Retrieves all the items on the stack. Since C<CPANPLUS::Error> is
+implemented using C<Log::Message>, consult its manpage for the
+function C<retrieve> to see what is returned and how to use the items.
+
+=head2 CPANPLUS::Error->stack_as_string([TRACE])
+
+Returns the whole stack as a printable string. If the C<TRACE> option is
+true all items are returned with C<Carp::longmess> output, rather than
+just the message.
+C<TRACE> defaults to false.
+
+=head2 CPANPLUS::Error->flush()
+
+Removes all the items from the stack and returns them. Since
+C<CPANPLUS::Error> is  implemented using C<Log::Message>, consult its
+manpage for the function C<retrieve> to see what is returned and how
+to use the items.
+
+=cut
+
+BEGIN {
+    use Exporter;
+    use Params::Check   qw[check];
+    use vars            qw[@EXPORT @ISA $ERROR_FH $MSG_FH];
+
+    @ISA        = 'Exporter';
+    @EXPORT     = qw[cp_error cp_msg error msg];
+
+    my $log     = new Log::Message;
+
+    for my $func ( @EXPORT ) {
+        no strict 'refs';
+        
+        my $prefix  = 'cp_';
+        my $name    = $func;
+        $name       =~ s/^$prefix//g;
+        
+        *$func = sub {
+                        my $msg     = shift;
+                        
+                        ### no point storing non-messages
+                        return unless defined $msg;
+                        
+                        $log->store(
+                                message => $msg,
+                                tag     => uc $name,
+                                level   => $prefix . $name,
+                                extra   => [@_]
+                        );
+                };
+    }
+
+    sub flush {
+        return reverse $log->flush;
+    }
+
+    sub stack {
+        return $log->retrieve( chrono => 1 );
+    }
+
+    sub stack_as_string {
+        my $class = shift;
+        my $trace = shift() ? 1 : 0;
+
+        return join $/, map {
+                        '[' . $_->tag . '] [' . $_->when . '] ' .
+                        ($trace ? $_->message . ' ' . $_->longmess
+                                : $_->message);
+                    } __PACKAGE__->stack;
+    }
+}
+
+=head1 GLOBAL VARIABLES
+
+=over 4
+
+=item $ERROR_FH
+
+This is the filehandle all the messages sent to C<error()> are being
+printed. This defaults to C<*STDERR>.
+
+=item $MSG_FH
+
+This is the filehandle all the messages sent to C<msg()> are being
+printed. This default to C<*STDOUT>.
+
+=cut
+local $| = 1;
+$ERROR_FH   = \*STDERR;
+$MSG_FH     = \*STDOUT;
+
+package Log::Message::Handlers;
+use Carp ();
+
+{
+
+    sub cp_msg {
+        my $self    = shift;
+        my $verbose = shift;
+
+        ### so you don't want us to print the msg? ###
+        return if defined $verbose && $verbose == 0;
+
+        my $old_fh = select $CPANPLUS::Error::MSG_FH;
+
+        print '['. $self->tag . '] ' . $self->message . "\n";
+        select $old_fh;
+
+        return;
+    }
+
+    sub cp_error {
+        my $self    = shift;
+        my $verbose = shift;
+
+        ### so you don't want us to print the error? ###
+        return if defined $verbose && $verbose == 0;
+
+        my $old_fh = select $CPANPLUS::Error::ERROR_FH;
+
+        ### is only going to be 1 for now anyway ###
+        ### C::I may not be loaded, so do a can() check first
+        my $cb      = CPANPLUS::Internals->can('_return_all_objects')
+                        ? (CPANPLUS::Internals->_return_all_objects)[0]
+                        : undef;
+
+        ### maybe we didn't initialize an internals object (yet) ###
+        my $debug   = $cb ? $cb->configure_object->get_conf('debug') : 0;
+        my $msg     =  '['. $self->tag . '] ' . $self->message . "\n";
+
+        ### i'm getting this warning in the test suite:
+        ### Ambiguous call resolved as CORE::warn(), qualify as such or
+        ### use & at CPANPLUS/Error.pm line 57.
+        ### no idea where it's coming from, since there's no 'sub warn'
+        ### anywhere to be found, but i'll mark it explicitly nonetheless
+        ### --kane
+        print $debug ? Carp::shortmess($msg) : $msg . "\n";
+
+        select $old_fh;
+
+        return;
+    }
+}
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/CPANPLUS/FAQ.pod b/lib/CPANPLUS/FAQ.pod
new file mode 100644 (file)
index 0000000..82bb57a
--- /dev/null
@@ -0,0 +1,30 @@
+=pod
+
+=head1 NAME
+
+CPANPLUS::FAQ
+
+=head1 DESCRIPTION
+
+This document attempts to provide answers to commonly asked questions.
+
+    XXX Work in progress
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c) 
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it 
+under the same terms as Perl itself.
+
+=cut
+
diff --git a/lib/CPANPLUS/Hacking.pod b/lib/CPANPLUS/Hacking.pod
new file mode 100644 (file)
index 0000000..c89a403
--- /dev/null
@@ -0,0 +1,142 @@
+=pod
+
+=head1 NAME
+
+CPANPLUS::Hacking
+
+=head1 DESCRIPTION
+
+This document attempts to describe how to easiest develop with the
+CPANPLUS environment, how certain things work and why.
+
+This is basically a quick-start guide to people who want to add
+features or patches to CPANPLUS.
+
+=head1 OBTAINING CPANPLUS
+
+CPANPLUS offers snapshots from the stable and unstable branches.
+After every patch to either of the branches, the snapshot is
+automatically updated.
+
+You can find the stable branch here (which should be equal to the
+CPAN release): L<http://p4.elixus.org/snap/cpanplus-dist.tar.gz>
+
+And the development branch here:
+L<http://p4.elixus.org/snap/cpanplus-devel.tar.gz>
+
+=head1 INSTALLING CPANPLUS
+
+CPANPLUS follows the standard perl module installation process:
+
+    perl Makefile.PL
+    make
+    make test
+    make install
+
+=head1 CONFIGURING CPANPLUS
+
+When running C<perl Makefile.PL> you will be prompted to configure.
+If you have already done so, and merely wish to update the C<Makefile>,
+simply run:
+
+    perl Makefile.PL JFDI=1
+
+This will keep your configuration intact. Note however, if there are
+changes to the default configuration file C<Config.pm-orig>, you should
+either delete your current config file and reconfigure, or patch your
+config file from the new entries in C<Config.pm-orig>.
+
+=head1 RUNNING CPANPLUS FROM DEVELOPMENT ENVIRONMENT
+
+If you'd rather not install the development version to your
+C<site_perl> directory, that's no problem. You can set your C<PERL5LIB>
+environment variable to CPANPLUS' C<lib> directory, and you can run it
+from there.
+
+=head1 RUNNING CPANPLUS TESTS
+
+Tests are what tells us if CPANPLUS is working. If a test is not working,
+try to run it explicilty like this:
+
+    perl -I/path/to/cpanplus/lib t/XX_name_of_test.t 1
+
+The extra '1' makes sure that all the messages and errors (they might
+be errors we're testing for!) are being printed rather than kept quiet.
+This is a great way to find out the context of any failures that may
+occur.
+
+If you believe this test failure proves a bug in CPANPLUS, the long
+output of the test file is something we'd like to see alongside your
+bug report.
+
+=head1 FINDING BUGS
+
+Sometimes you might find bugs in CPANPLUS' behaviour. If you encounter
+these in a development snapshot, we'd appreciate a complete patch (as
+described below in the L<SENDING PATCHES> section.
+
+If it's way over your head, then of course reporting the bug is always
+better than not reporting it at all. Before you do so though, make
+sure you have the B<latest> development snapshot, and the bug still
+persists there. If so, report the bug to this address:
+
+    cpanplus-devel@lists.sourceforge.net
+
+A good C<patch> would have the following characteristics:
+
+=over 4
+
+=item Problem description
+
+Describe clearly what the bug is you found, and what it should have
+done instead.
+
+=item Program demonstrating the bug
+
+Show us how to reproduce the bug, in a simple of a program as possible
+
+=item [OPTIONAL] A patch to the test suite to test for the bug
+
+Amend our test suite by making sure this bug will be found in this, and
+future versions of CPANPLUS (see L<SUPPLYING PATCHES>)
+
+=item [OPTIONAL] A patch to the code + tests + documentation
+
+Fix the bug, update the docs & tests. That way your bug will be gone
+forever :)
+
+=back
+
+=head1 SUPPLYING PATCHES
+
+Patches are a good thing, and they are welcome. Especially if they fix
+bugs you've found along the way, or that others have reported.
+
+We prefer patches in the following format:
+
+=over 4
+
+=item * In C<diff -u> or C<diff -c> format
+
+=item * From the root of the snapshot
+
+=item * Including patches for code + tests + docs
+
+=item * Sent per mail to cpanplus-devel@lists.sourceforge.net
+
+=item * With subject containing C<[PATCH]> + description of the patch
+
+=back
+
+You will always be informed if a patch is applied or rejected, and in
+case of rejection why that is (perhaps you can tweak the patch to have
+it accepted after all).
+
+=cut
+
+__END__
+
+* perl5lib
+* perl t/foo 1
+* patches to cpanplus-devel
+* snap/devel.tgz
diff --git a/lib/CPANPLUS/Internals.pm b/lib/CPANPLUS/Internals.pm
new file mode 100644 (file)
index 0000000..0ba2529
--- /dev/null
@@ -0,0 +1,489 @@
+package CPANPLUS::Internals;
+
+### we /need/ perl5.6.1 or higher -- we use coderefs in @INC,
+### and 5.6.0 is just too buggy
+use 5.006001;
+
+use strict;
+use Config;
+
+
+use CPANPLUS::Error;
+
+use CPANPLUS::Selfupdate;
+
+use CPANPLUS::Internals::Source;
+use CPANPLUS::Internals::Extract;
+use CPANPLUS::Internals::Fetch;
+use CPANPLUS::Internals::Utils;
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Internals::Search;
+use CPANPLUS::Internals::Report;
+
+use Cwd                         qw[cwd];
+use Params::Check               qw[check];
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+
+use Object::Accessor;
+
+
+local $Params::Check::VERBOSE = 1;
+
+use vars qw[@ISA $VERSION];
+
+@ISA = qw[
+            CPANPLUS::Internals::Source
+            CPANPLUS::Internals::Extract
+            CPANPLUS::Internals::Fetch
+            CPANPLUS::Internals::Utils
+            CPANPLUS::Internals::Search
+            CPANPLUS::Internals::Report
+        ];
+
+$VERSION = "0.78";
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Internals
+
+=head1 SYNOPSIS
+
+    my $internals   = CPANPLUS::Internals->_init( _conf => $conf );
+    my $backend     = CPANPLUS::Internals->_retrieve_id( $ID );
+
+=head1 DESCRIPTION
+
+This module is the guts of CPANPLUS -- it inherits from all other
+modules in the CPANPLUS::Internals::* namespace, thus defying normal
+rules of OO programming -- but if you're reading this, you already
+know what's going on ;)
+
+Please read the C<CPANPLUS::Backend> documentation for the normal API.
+
+=head1 ACCESSORS
+
+=over 4
+
+=item _conf
+
+Get/set the configure object
+
+=item _id
+
+Get/set the id
+
+=item _lib
+
+Get/set the current @INC path -- @INC is reset to this after each
+install.
+
+=item _perl5lib
+
+Get/set the current PERL5LIB environment variable -- $ENV{PERL5LIB}
+is reset to this after each install.
+
+=cut
+
+### autogenerate accessors ###
+for my $key ( qw[_conf _id _lib _perl5lib _modules _hosts _methods _status
+                 _callbacks _selfupdate]
+) {
+    no strict 'refs';
+    *{__PACKAGE__."::$key"} = sub {
+        $_[0]->{$key} = $_[1] if @_ > 1;
+        return $_[0]->{$key};
+    }
+}
+
+=pod
+
+=head1 METHODS
+
+=head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )
+
+C<_init> creates a new CPANPLUS::Internals object.
+
+You have to pass it a valid C<CPANPLUS::Configure> object.
+
+Returns the object on success, or dies on failure.
+
+=cut
+{   ### NOTE:
+    ### if extra callbacks are added, don't forget to update the
+    ### 02-internals.t test script with them!
+    my $callback_map = {
+        ### name            default value    
+        install_prerequisite    => 1,   # install prereqs when 'ask' is set?
+        edit_test_report        => 0,   # edit the prepared test report?
+        send_test_report        => 1,   # send the test report?
+                                        # munge the test report
+        munge_test_report       => sub { return $_[1] },
+                                        # filter out unwanted prereqs
+        filter_prereqs          => sub { return $_[1] },
+    };
+    
+    my $status = Object::Accessor->new;
+    $status->mk_accessors(qw[pending_prereqs]);
+
+    my $callback = Object::Accessor->new;
+    $callback->mk_accessors(keys %$callback_map);
+
+    my $conf;
+    my $Tmpl = {
+        _conf       => { required => 1, store => \$conf,
+                            allow => IS_CONFOBJ },
+        _id         => { default => '',                 no_override => 1 },
+        _lib        => { default => [ @INC ],           no_override => 1 },
+        _perl5lib   => { default => $ENV{'PERL5LIB'},   no_override => 1 },
+        _authortree => { default => '',                 no_override => 1 },
+        _modtree    => { default => '',                 no_override => 1 },
+        _hosts      => { default => {},                 no_override => 1 },
+        _methods    => { default => {},                 no_override => 1 },
+        _status     => { default => '<empty>',          no_override => 1 },
+        _callbacks  => { default => '<empty>',          no_override => 1 },
+    };
+
+    sub _init {
+        my $class   = shift;
+        my %hash    = @_;
+
+        ### temporary warning until we fix the storing of multiple id's
+        ### and their serialization:
+        ### probably not going to happen --kane
+        if( my $id = $class->_last_id ) {
+            # make it a singleton.
+            warn loc(q[%1 currently only supports one %2 object per ] .
+                     q[running program], 'CPANPLUS', $class);
+
+            return $class->_retrieve_id( $id );
+        }
+
+        my $args = check($Tmpl, \%hash)
+                    or die loc(qq[Could not initialize '%1' object], $class);
+
+        bless $args, $class;
+
+        $args->{'_id'}          = $args->_inc_id;
+        $args->{'_status'}      = $status;
+        $args->{'_callbacks'}   = $callback;
+
+        ### initialize callbacks to default state ###
+        for my $name ( $callback->ls_accessors ) {
+            my $rv = ref $callback_map->{$name} ? 'sub return value' :
+                         $callback_map->{$name} ? 'true' : 'false';
+        
+            $args->_callbacks->$name(
+                sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'",
+                              $name, $rv), $args->_conf->get_conf('debug')); 
+                      return ref $callback_map->{$name} 
+                                ? $callback_map->{$name}->( @_ )
+                                : $callback_map->{$name};
+                } 
+            );
+        }
+
+        ### create a selfupdate object
+        $args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );
+
+        ### initalize it as an empty hashref ###
+        $args->_status->pending_prereqs( {} );
+
+        ### allow for dirs to be added to @INC at runtime,
+        ### rather then compile time
+        push @INC, @{$conf->get_conf('lib')};
+
+        ### add any possible new dirs ###
+        $args->_lib( [@INC] );
+
+        $conf->_set_build( startdir => cwd() ),
+            or error( loc("couldn't locate current dir!") );
+
+        $ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
+
+        my $id = $args->_store_id( $args );
+
+        unless ( $id == $args->_id ) {
+            error( loc("IDs do not match: %1 != %2. Storage failed!",
+                        $id, $args->_id) );
+        }
+
+        return $args;
+    }
+
+=pod
+
+=head2 $bool = $internals->_flush( list => \@caches )
+
+Flushes the designated caches from the C<CPANPLUS> object.
+
+Returns true on success, false if one or more caches could not be
+be flushed.
+
+=cut
+
+    sub _flush {
+        my $self = shift;
+        my %hash = @_;
+
+        my $aref;
+        my $tmpl = {
+            list    => { required => 1, default => [],
+                            strict_type => 1, store => \$aref },
+        };
+
+        my $args = check( $tmpl, \%hash ) or return;
+
+        my $flag = 0;
+        for my $what (@$aref) {
+            my $cache = '_' . $what;
+
+            ### set the include paths back to their original ###
+            if( $what eq 'lib' ) {
+                $ENV{PERL5LIB}  = $self->_perl5lib || '';
+                @INC            = @{$self->_lib};
+
+            ### give all modules a new status object -- this is slightly
+            ### costly, but the best way to make sure all statusses are
+            ### forgotten --kane
+            } elsif ( $what eq 'modules' ) {
+                for my $modobj ( values %{$self->module_tree} ) {
+                    $modobj->_flush;
+                }
+
+            ### blow away the methods cache... currently, that's only
+            ### File::Fetch's method fail list
+            } elsif ( $what eq 'methods' ) {
+
+                ### still fucking p4 :( ###
+                $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};
+
+            ### blow away the m::l::c cache, so modules can be (re)loaded
+            ### again if they become available
+            } elsif ( $what eq 'load' ) {
+                undef $Module::Load::Conditional::CACHE;
+
+            } else {
+                unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
+                    error( loc( "No such cache: '%1'", $what ) );
+                    $flag++;
+                    next;
+                } else {
+                    $self->$cache( {} );
+                }
+            }
+        }
+        return !$flag;
+    }
+
+### NOTE:
+### if extra callbacks are added, don't forget to update the
+### 02-internals.t test script with them!
+
+=pod 
+
+=head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );
+
+Registers a callback for later use by the internal libraries.
+
+Here is a list of the currently used callbacks:
+
+=over 4
+
+=item install_prerequisite
+
+Is called when the user wants to be C<asked> about what to do with
+prerequisites. Should return a boolean indicating true to install
+the prerequisite and false to skip it.
+
+=item send_test_report
+
+Is called when the user should be prompted if he wishes to send the
+test report. Should return a boolean indicating true to send the 
+test report and false to skip it.
+
+=item munge_test_report
+
+Is called when the test report message has been composed, giving
+the user a chance to programatically alter it. Should return the 
+(munged) message to be sent.
+
+=item edit_test_report
+
+Is called when the user should be prompted to edit test reports
+about to be sent out by Test::Reporter. Should return a boolean 
+indicating true to edit the test report in an editor and false 
+to skip it.
+
+=back
+
+=cut
+
+    sub _register_callback {
+        my $self = shift or return;
+        my %hash = @_;
+
+        my ($name,$code);
+        my $tmpl = {
+            name    => { required => 1, store => \$name,
+                         allow => [$callback->ls_accessors] },
+            code    => { required => 1, allow => IS_CODEREF,
+                         store => \$code },
+        };
+
+        check( $tmpl, \%hash ) or return;
+
+        $self->_callbacks->$name( $code ) or return;
+
+        return 1;
+    }
+
+# =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF );
+# 
+# Adds a new callback to be used from anywhere in the system. If the callback
+# is already known, an error is raised and false is returned. If the callback
+# is not yet known, it is added, and the corresponding coderef is registered
+# using the
+# 
+# =cut
+# 
+#     sub _add_callback {
+#         my $self = shift or return;
+#         my %hash = @_;
+#         
+#         my ($name,$code);
+#         my $tmpl = {
+#             name    => { required => 1, store => \$name, },
+#             code    => { required => 1, allow => IS_CODEREF,
+#                          store => \$code },
+#         };
+# 
+#         check( $tmpl, \%hash ) or return;
+# 
+#         if( $callback->can( $name ) ) {
+#             error(loc("Callback '%1' is already registered"));
+#             return;
+#         }
+# 
+#         $callback->mk_accessor( $name );
+# 
+#         $self->_register_callback( name => $name, code => $code ) or return;
+# 
+#         return 1;
+#     }
+
+}
+
+=pod
+
+=head2 $bool = $internals->_add_to_includepath( directories => \@dirs )
+
+Adds a list of directories to the include path.
+This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _add_to_includepath {
+    my $self = shift;
+    my %hash = @_;
+
+    my $dirs;
+    my $tmpl = {
+        directories => { required => 1, default => [], store => \$dirs,
+                         strict_type => 1 },
+    };
+
+    check( $tmpl, \%hash ) or return;
+
+    for my $lib (@$dirs) {
+        push @INC, $lib unless grep { $_ eq $lib } @INC;
+    }
+
+    {   local $^W;  ### it will be complaining if $ENV{PERL5LIB]
+                    ### is not defined (yet).
+        $ENV{'PERL5LIB'} .= join '', map { $Config{'path_sep'} . $_ } @$dirs;
+    }
+
+    return 1;
+}
+
+=pod
+
+=head2 $id = CPANPLUS::Internals->_last_id
+
+Return the id of the last object stored.
+
+=head2 $id = CPANPLUS::Internals->_store_id( $internals )
+
+Store this object; return its id.
+
+=head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )
+
+Retrieve an object based on its ID -- return false on error.
+
+=head2 CPANPLUS::Internals->_remove_id( $ID )
+
+Remove the object marked by $ID from storage.
+
+=head2 @objs = CPANPLUS::Internals->_return_all_objects
+
+Return all stored objects.
+
+=cut
+
+
+### code for storing multiple objects
+### -- although we only support one right now
+### XXX when support for multiple objects comes, saving source will have
+### to change
+{
+    my $idref = {};
+    my $count = 0;
+
+    sub _inc_id { return ++$count; }
+
+    sub _last_id { $count }
+
+    sub _store_id {
+        my $self    = shift;
+        my $obj     = shift or return;
+
+       unless( IS_INTERNALS_OBJ->($obj) ) {
+            error( loc("The object you passed has the wrong ref type: '%1'",
+                        ref $obj) );
+            return;
+        }
+
+        $idref->{ $obj->_id } = $obj;
+        return $obj->_id;
+    }
+
+    sub _retrieve_id {
+        my $self    = shift;
+        my $id      = shift or return;
+
+        my $obj = $idref->{$id};
+        return $obj;
+    }
+
+    sub _remove_id {
+        my $self    = shift;
+        my $id      = shift or return;
+
+        return delete $idref->{$id};
+    }
+
+    sub _return_all_objects { return values %$idref }
+}
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/CPANPLUS/Internals/Constants.pm b/lib/CPANPLUS/Internals/Constants.pm
new file mode 100644 (file)
index 0000000..0961e25
--- /dev/null
@@ -0,0 +1,302 @@
+package CPANPLUS::Internals::Constants;
+
+use strict;
+
+use CPANPLUS::Error;
+
+use File::Spec;
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+
+require Exporter;
+use vars    qw[$VERSION @ISA @EXPORT];
+
+use Package::Constants;
+
+
+$VERSION    = 0.01;
+@ISA        = qw[Exporter];
+@EXPORT     = Package::Constants->list( __PACKAGE__ );
+
+
+sub constants { @EXPORT };
+
+use constant INSTALLER_BUILD
+                            => 'CPANPLUS::Dist::Build';
+use constant INSTALLER_MM   => 'CPANPLUS::Dist::MM';    
+use constant INSTALLER_SAMPLE   
+                            => 'CPANPLUS::Dist::Sample';
+use constant INSTALLER_BASE => 'CPANPLUS::Dist::Base';                            
+
+use constant CONFIG         => 'CPANPLUS::Config';
+use constant CONFIG_USER    => 'CPANPLUS::Config::User';
+use constant CONFIG_SYSTEM  => 'CPANPLUS::Config::System';
+
+use constant TARGET_CREATE  => 'create';
+use constant TARGET_PREPARE => 'prepare';
+use constant TARGET_INSTALL => 'install';
+use constant TARGET_IGNORE  => 'ignore';
+use constant DOT_CPANPLUS   => $^O eq 'VMS' ? '_cpanplus' : '.cpanplus';         
+
+use constant OPT_AUTOFLUSH  => '-MCPANPLUS::Internals::Utils::Autoflush';
+
+use constant UNKNOWN_DL_LOCATION
+                            => 'UNKNOWN-ORIGIN';   
+
+use constant NMAKE          => 'nmake.exe';
+use constant NMAKE_URL      => 
+                        'ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe';
+
+use constant INSTALL_VIA_PACKAGE_MANAGER 
+                            => sub { my $fmt = $_[0] or return;
+                                     return 1 if $fmt ne INSTALLER_BUILD and
+                                                 $fmt ne INSTALLER_MM;
+                            };                                                 
+
+use constant IS_CODEREF     => sub { ref $_[-1] eq 'CODE' };
+use constant IS_MODOBJ      => sub { UNIVERSAL::isa($_[-1], 
+                                            'CPANPLUS::Module') }; 
+use constant IS_FAKE_MODOBJ => sub { UNIVERSAL::isa($_[-1],
+                                            'CPANPLUS::Module::Fake') };
+use constant IS_AUTHOBJ     => sub { UNIVERSAL::isa($_[-1],
+                                            'CPANPLUS::Module::Author') };
+use constant IS_FAKE_AUTHOBJ
+                            => sub { UNIVERSAL::isa($_[-1],
+                                            'CPANPLUS::Module::Author::Fake') };
+
+use constant IS_CONFOBJ     => sub { UNIVERSAL::isa($_[-1],
+                                            'CPANPLUS::Configure') };
+
+use constant IS_RVOBJ       => sub { UNIVERSAL::isa($_[-1],
+                                            'CPANPLUS::Backend::RV') };
+                                            
+use constant IS_INTERNALS_OBJ
+                            => sub { UNIVERSAL::isa($_[-1],
+                                            'CPANPLUS::Internals') };                                            
+                                            
+use constant IS_FILE        => sub { return 1 if -e $_[-1] };                                            
+
+use constant FILE_EXISTS    => sub {  
+                                    my $file = $_[-1];
+                                    return 1 if IS_FILE->($file);
+                                    local $Carp::CarpLevel = 
+                                            $Carp::CarpLevel+2;
+                                    error(loc(  q[File '%1' does not exist],
+                                                $file));
+                                    return;
+                            };    
+
+use constant FILE_READABLE  => sub {  
+                                    my $file = $_[-1];
+                                    return 1 if -e $file && -r _;
+                                    local $Carp::CarpLevel = 
+                                            $Carp::CarpLevel+2;
+                                    error( loc( q[File '%1' is not readable ].
+                                                q[or does not exist], $file));
+                                    return;
+                            };    
+use constant IS_DIR         => sub { return 1 if -d $_[-1] };
+
+use constant DIR_EXISTS     => sub { 
+                                    my $dir = $_[-1];
+                                    return 1 if IS_DIR->($dir);
+                                    local $Carp::CarpLevel = 
+                                            $Carp::CarpLevel+2;                                    
+                                    error(loc(q[Dir '%1' does not exist],
+                                            $dir));
+                                    return;
+                            };   
+
+use constant MAKEFILE_PL    => sub { return @_
+                                        ? File::Spec->catfile( @_,
+                                                            'Makefile.PL' )
+                                        : 'Makefile.PL';
+                            };                   
+use constant MAKEFILE       => sub { return @_
+                                        ? File::Spec->catfile( @_,
+                                                            'Makefile' )
+                                        : 'Makefile';
+                            }; 
+use constant BUILD_PL       => sub { return @_
+                                        ? File::Spec->catfile( @_,
+                                                            'Build.PL' )
+                                        : 'Build.PL';
+                            };
+                            
+use constant BLIB           => sub { return @_
+                                        ? File::Spec->catfile(@_, 'blib')
+                                        : 'blib';
+                            };                  
+
+use constant LIB            => 'lib';
+use constant LIB_DIR        => sub { return @_
+                                        ? File::Spec->catdir(@_, LIB)
+                                        : LIB;
+                            }; 
+use constant AUTO           => 'auto';                            
+use constant LIB_AUTO_DIR   => sub { return @_
+                                        ? File::Spec->catdir(@_, LIB, AUTO)
+                                        : File::Spec->catdir(LIB, AUTO)
+                            }; 
+use constant ARCH           => 'arch';
+use constant ARCH_DIR       => sub { return @_
+                                        ? File::Spec->catdir(@_, ARCH)
+                                        : ARCH;
+                            }; 
+use constant ARCH_AUTO_DIR  => sub { return @_
+                                        ? File::Spec->catdir(@_,ARCH,AUTO)
+                                        : File::Spec->catdir(ARCH,AUTO)
+                            };                            
+
+use constant BLIB_LIBDIR    => sub { return @_
+                                        ? File::Spec->catdir(
+                                                @_, BLIB->(), LIB )
+                                        : File::Spec->catdir( BLIB->(), LIB );
+                            };  
+
+use constant CONFIG_USER_LIB_DIR => sub { 
+                                    require CPANPLUS::Internals::Utils;
+                                    LIB_DIR->(
+                                        CPANPLUS::Internals::Utils->_home_dir,
+                                        DOT_CPANPLUS
+                                    );
+                                };        
+use constant CONFIG_USER_FILE    => sub {
+                                    File::Spec->catfile(
+                                        CONFIG_USER_LIB_DIR->(),
+                                        split('::', CONFIG_USER),
+                                    ) . '.pm';
+                                };
+use constant CONFIG_SYSTEM_FILE  => sub {
+                                    require CPANPLUS::Internals;
+                                    require File::Basename;
+                                    my $dir = File::Basename::dirname(
+                                        $INC{'CPANPLUS/Internals.pm'}
+                                    );
+                                
+                                    ### XXX use constants
+                                    File::Spec->catfile( 
+                                        $dir, qw[Config System.pm]
+                                    );
+                                };        
+      
+use constant README         => sub { my $obj = $_[0];
+                                     my $pkg = $obj->package_name;
+                                     $pkg .= '-' . $obj->package_version .
+                                             '.readme';
+                                     return $pkg;
+                            };
+use constant OPEN_FILE      => sub {
+                                    my($file, $mode) = (@_, '');
+                                    my $fh;
+                                    open $fh, "$mode" . $file
+                                        or error(loc(
+                                            "Could not open file '%1': %2",
+                                             $file, $!));
+                                    return $fh if $fh;
+                                    return;
+                            };      
+                            
+use constant STRIP_GZ_SUFFIX 
+                            => sub {
+                                    my $file = $_[0] or return;
+                                    $file =~ s/.gz$//i;
+                                    return $file;
+                            };            
+                                        
+use constant CHECKSUMS      => 'CHECKSUMS';
+use constant PGP_HEADER     => '-----BEGIN PGP SIGNED MESSAGE-----';
+use constant ENV_CPANPLUS_CONFIG
+                            => 'PERL5_CPANPLUS_CONFIG';
+use constant ENV_CPANPLUS_IS_EXECUTING
+                            => 'PERL5_CPANPLUS_IS_EXECUTING';
+use constant DEFAULT_EMAIL  => 'cpanplus@example.com';   
+use constant CPANPLUS_UA    => sub { ### for the version number ###
+                                     require CPANPLUS::Internals;
+                                     "CPANPLUS/$CPANPLUS::Internals::VERSION" 
+                                };
+use constant TESTERS_URL    => sub {
+                                    "http://testers.cpan.org/show/" .
+                                    $_[0] .".yaml" 
+                                };
+use constant TESTERS_DETAILS_URL
+                            => sub {
+                                    'http://testers.cpan.org/show/' .
+                                    $_[0] . '.html';
+                                };         
+
+use constant CREATE_FILE_URI    
+                            => sub { 
+                                    my $dir = $_[0] or return;
+                                    return $dir =~ m|^/| 
+                                        ? 'file:/'  . $dir
+                                        : 'file://' . $dir;   
+                            };        
+
+use constant DOT_SHELL_DEFAULT_RC
+                            => '.shell-default.rc';
+
+use constant PREREQ_IGNORE  => 0;                
+use constant PREREQ_INSTALL => 1;
+use constant PREREQ_ASK     => 2;
+use constant PREREQ_BUILD   => 3;
+use constant BOOLEANS       => [0,1];
+use constant CALLING_FUNCTION   
+                            => sub { my $lvl = $_[0] || 0;
+                                     return join '::', (caller(2+$lvl))[3] 
+                                };
+use constant PERL_CORE      => 'perl';
+
+use constant GET_XS_FILES   => sub { my $dir = $_[0] or return;
+                                     require File::Find;
+                                     my @files;
+                                     File::Find::find( 
+                                        sub { push @files, $File::Find::name
+                                                if $File::Find::name =~ /\.xs$/i
+                                        }, $dir );
+                                           
+                                     return @files;
+                                };  
+
+use constant INSTALL_LOG_FILE 
+                            => sub { my $obj  = shift or return;
+                                     my $name = $obj->name; $name =~ s/::/-/g;
+                                     $name .= '-'. $obj->version;
+                                     $name .= '-'. scalar(time) . '.log';
+                                     return $name;
+                                };                                        
+
+use constant ON_WIN32       => $^O eq 'MSWin32';
+use constant ON_NETWARE     => $^O eq 'NetWare';
+use constant ON_CYGWIN      => $^O eq 'cygwin';
+use constant ON_VMS         => $^O eq 'VMS';
+
+use constant ON_OLD_CYGWIN  => do { ON_CYGWIN and $] < 5.008 
+                                    ? loc(
+                                       "Your perl version for %1 is too low; ".
+                                       "Require %2 or higher for this function",
+                                       $^O, '5.8.0' )
+                                    : '';                                                                           
+                                };
+
+### XXX these 2 are probably obsolete -- check & remove;
+use constant DOT_EXISTS     => '.exists'; 
+
+use constant QUOTE_PERL_ONE_LINER 
+                            => sub { my $line = shift or return;
+
+                                     ### use double quotes on these systems
+                                     return qq["$line"] 
+                                        if ON_WIN32 || ON_NETWARE || ON_VMS;
+
+                                     ### single quotes on the rest
+                                     return qq['$line'];
+                            };   
+
+1;              
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/CPANPLUS/Internals/Constants/Report.pm b/lib/CPANPLUS/Internals/Constants/Report.pm
new file mode 100644 (file)
index 0000000..10a14e6
--- /dev/null
@@ -0,0 +1,357 @@
+package CPANPLUS::Internals::Constants::Report;
+
+use strict;
+use CPANPLUS::Error;
+
+use File::Spec;
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+
+require Exporter;
+use vars    qw[$VERSION @ISA @EXPORT];
+
+use Package::Constants;
+
+
+$VERSION    = 0.01;
+@ISA        = qw[Exporter];
+@EXPORT     = Package::Constants->list( __PACKAGE__ );
+
+### for the version
+require CPANPLUS::Internals;
+
+### OS to regex map ###
+my %OS = (
+    Amiga       => 'amigaos',
+    Atari       => 'mint',
+    BSD         => 'bsdos|darwin|freebsd|openbsd|netbsd',
+    Be          => 'beos',
+    BeOS        => 'beos',
+    Cygwin      => 'cygwin',
+    Darwin      => 'darwin',
+    EBCDIC      => 'os390|os400|posix-bc|vmesa',
+    HPUX        => 'hpux',
+    Linux       => 'linux',
+    MSDOS       => 'dos|os2|MSWin32|cygwin',
+    'bin\\d*Mac'=> 'MacOS|darwin', # binMac, bin56Mac, bin58Mac...
+    Mac         => 'MacOS|darwin',
+    MacPerl     => 'MacOS',
+    MacOS       => 'MacOS|darwin',
+    MacOSX      => 'darwin',
+    MPE         => 'mpeix',
+    MPEiX       => 'mpeix',
+    OS2         => 'os2',
+    Plan9       => 'plan9',
+    RISCOS      => 'riscos',
+    SGI         => 'irix',
+    Solaris     => 'solaris',
+    Unix        => 'aix|bsdos|darwin|dgux|dynixptx|freebsd|'.
+                   'linux|hpux|machten|netbsd|next|openbsd|dec_osf|'.
+                   'svr4|sco_sv|unicos|unicosmk|solaris|sunos',
+    VMS         => 'VMS',
+    VOS         => 'VOS',
+    Win32       => 'MSWin32|cygwin',
+    Win32API    => 'MSWin32|cygwin',
+);
+
+use constant GRADE_FAIL     => 'fail';
+use constant GRADE_PASS     => 'pass';
+use constant GRADE_NA       => 'na';
+use constant GRADE_UNKNOWN  => 'unknown';
+
+use constant MAX_REPORT_SEND
+                            => 2;
+
+use constant CPAN_TESTERS_EMAIL
+                            => 'cpan-testers@perl.org';
+
+### the cpan mail account for this user ###
+use constant CPAN_MAIL_ACCOUNT
+                            => sub {
+                                my $username = shift or return;
+                                return $username . '@cpan.org';
+                            };
+
+### check if this module is platform specific and if we're on that
+### specific platform. Alternately, the module is not platform specific
+### and we're always OK to send out test results.
+use constant RELEVANT_TEST_RESULT
+                            => sub {
+                                my $mod  = shift or return;
+                                my $name = $mod->module;
+                                my $specific;
+                                for my $platform (keys %OS) {
+                                    if( $name =~ /\b$platform\b/i ) {
+                                        # beware the Mac != MAC
+                                        next if($platform eq 'Mac' &&
+                                                $name !~ /\b$platform\b/);
+                                        $specific++;
+                                        return 1 if
+                                            $^O =~ /^(?:$OS{$platform})$/
+                                    }
+                                };
+                                return $specific ? 0 : 1;
+                            };
+
+use constant UNSUPPORTED_OS
+                            => sub {
+                                my $buffer = shift or return;
+                                if( $buffer =~
+                                        /No support for OS|OS unsupported/im ) {
+                                    return 1;
+                                }
+                                return 0;
+                          };                                            
+
+use constant PERL_VERSION_TOO_LOW
+                            => sub {
+                                my $buffer = shift or return;
+                                # ExtUtils::MakeMaker format
+                                if( $buffer =~
+                                        /Perl .*? required--this is only .*?/m ) {
+                                    return 1;
+                                }
+                                # Module::Build format
+                                if( $buffer =~
+                                        /ERROR:( perl:)? Version .*?( of perl)? is installed, but we need version >= .*?/m ) {
+                                    return 1;
+                                }
+                                return 0;
+                          };                                            
+
+use constant NO_TESTS_DEFINED
+                            => sub {
+                                my $buffer = shift or return;
+                                if( $buffer =~
+                                  /(No tests defined( for [\w:]+ extension)?\.)/
+                                  and $buffer !~ /\*\.t/m and
+                                      $buffer !~ /test\.pl/m
+                                ) { 
+                                    return $1 
+                                }
+                                
+                                return;
+                            };
+
+### what stage did the test fail? ###
+use constant TEST_FAIL_STAGE
+                            => sub {
+                                my $buffer = shift or return;
+                                return $buffer =~ /(MAKE [A-Z]+).*/
+                                    ? lc $1 :
+                                    'fetch';
+                            };
+
+
+use constant MISSING_PREREQS_LIST
+                            => sub {
+                                my $buffer = shift;
+                                my @list = map { s/.pm$//; s|/|::|g; $_ }
+                                    ($buffer =~
+                                        m/\bCan\'t locate (\S+) in \@INC/g);
+                                
+                                ### make sure every missing prereq is only 
+                                ### listed ones
+                                {   my %seen;
+                                    @list = grep { !$seen{$_}++ } @list
+                                }
+
+                                return @list;
+                            };
+
+use constant MISSING_EXTLIBS_LIST
+                            => sub {
+                                my $buffer = shift;
+                                my @list = 
+                                    ($buffer =~
+                                        m/No library found for -l([-\w]+)/g);
+
+                                return @list;
+                            };
+
+use constant REPORT_MESSAGE_HEADER
+                            => sub {
+                                my ($version, $author) = @_;
+                                return << ".";
+
+Dear $author,
+    
+This is a computer-generated error report created automatically by
+CPANPLUS, version $version. Testers personal comments may appear 
+at the end of this report.
+
+.
+                            };
+
+use constant REPORT_MESSAGE_FAIL_HEADER
+                            => sub {
+                                my($stage, $buffer) = @_;
+                                return << ".";
+
+Thank you for uploading your work to CPAN.  However, it appears that
+there were some problems testing your distribution.
+
+TEST RESULTS:
+
+Below is the error stack from stage '$stage':
+
+$buffer
+
+.
+                            };
+
+use constant REPORT_MISSING_PREREQS
+                            => sub {
+                                my ($author,$email,@missing) = @_;
+                                $author = ($author && $email) 
+                                            ? "$author ($email)" 
+                                            : 'Your Name Here';
+                                
+                                my $modules = join "\n", @missing;
+                                my $prereqs = join "\n", 
+                                    map {"\t'$_'\t=> '0',".
+                                         " # or a minimum working version"}
+                                    @missing;
+
+                                return << ".";
+
+MISSING PREREQUISITES:
+
+It was observed that the test suite seem to fail without these modules:
+
+$modules
+
+As such, adding the prerequisite module(s) to 'PREREQ_PM' in your
+Makefile.PL should solve this problem.  For example:
+
+WriteMakefile(
+    AUTHOR      => '$author',
+    ... # other information
+    PREREQ_PM   => {
+$prereqs
+    }
+);
+
+If you are interested in making a more flexible Makefile.PL that can
+probe for missing dependencies and install them, ExtUtils::AutoInstall
+at <http://search.cpan.org/dist/ExtUtils-AutoInstall/> may be
+worth a look.
+
+Thanks! :-)
+
+.
+                            };
+
+use constant REPORT_MISSING_TESTS
+                            => sub {
+                                return << ".";
+RECOMMENDATIONS:
+
+It would be very helpful if you could include even a simple test 
+script in the next release, so people can verify which platforms
+can successfully install them, as well as avoid regression bugs?
+
+A simple 't/use.t' that says:
+
+#!/usr/bin/env perl -w
+use strict;
+use Test;
+BEGIN { plan tests => 1 }
+
+use Your::Module::Here; ok(1);
+exit;
+__END__
+
+would be appreciated.  If you are interested in making a more robust
+test suite, please see the Test::Simple, Test::More and Test::Tutorial
+documentation at <http://search.cpan.org/dist/Test-Simple/>.
+
+Thanks!  :-)
+
+.
+                            };
+
+use constant REPORT_LOADED_PREREQS 
+                            => sub {
+                                my $mod = shift;
+                                my $cb  = $mod->parent;
+                                my $prq = $mod->status->prereqs || {};
+
+                                ### not every prereq may be coming from CPAN
+                                ### so maybe we wont find it in our module
+                                ### tree at all... 
+                                ### skip ones that cant be found in teh list
+                                ### as reported in #12723
+                                my @prq = grep { defined }
+                                          map { $cb->module_tree($_) }
+                                          sort keys %$prq;
+                                
+                                ### no prereqs?
+                                return '' unless @prq;
+
+                                ### some apparently, list what we loaded
+                                my $str = << ".";
+PREREQUISITES:
+
+Here is a list of prerequisites you specified and versions we 
+managed to load:
+                                
+.
+                                $str .= join '', 
+                                        map { my $want = $prq->{$_->name};
+                                              
+                                              sprintf "\t%s %-30s %8s %8s\n", 
+                                              do { $_->is_uptodate( 
+                                                    version => $want
+                                                   ) ? ' ' : '!' 
+                                              },
+                                              $_->name,
+                                              $_->installed_version,
+                                              $want
+                                              
+                                        ### might be empty entries in there
+                                        } grep { defined $_ } @prq;   
+                                
+                                return $str;
+                            };
+
+use constant REPORT_TESTS_SKIPPED 
+                            => sub {
+                                return << ".";
+
+******************************** NOTE ********************************
+***                                                                ***
+***    The tests for this module were skipped during this build    ***
+***                                                                ***
+**********************************************************************
+
+.
+                            };
+                            
+use constant REPORT_MESSAGE_FOOTER
+                            => sub {
+                                return << ".";
+
+******************************** NOTE ********************************
+The comments above are created mechanically, possibly without manual
+checking by the sender.  As there are many people performing automatic
+tests on each upload to CPAN, it is likely that you will receive 
+identical messages about the same problem.
+
+If you believe that the message is mistaken, please reply to the first
+one with correction and/or additional informations, and do not take
+it personally.  We appreciate your patience. :)
+**********************************************************************
+
+Additional comments:
+.
+                             };
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/CPANPLUS/Internals/Extract.pm b/lib/CPANPLUS/Internals/Extract.pm
new file mode 100644 (file)
index 0000000..544d589
--- /dev/null
@@ -0,0 +1,236 @@
+package CPANPLUS::Internals::Extract;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use File::Spec                  ();
+use File::Basename              ();
+use Archive::Extract;
+use IPC::Cmd                    qw[run];
+use Params::Check               qw[check];
+use Module::Load::Conditional   qw[can_load check_install];
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+
+local $Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Internals::Extract
+
+=head1 SYNOPSIS
+
+    ### for source files ###
+    $self->_gunzip( file => 'foo.gz', output => 'blah.txt' );
+    
+    ### for modules/packages ###
+    $dir = $self->_extract( module      => $modobj, 
+                            extractdir  => '/some/where' );
+
+=head1 DESCRIPTION
+
+CPANPLUS::Internals::Extract extracts compressed files for CPANPLUS.
+It can do this by either a pure perl solution (preferred) with the 
+use of C<Archive::Tar> and C<Compress::Zlib>, or with binaries, like
+C<gzip> and C<tar>.
+The flow looks like this:
+
+    $cb->_extract
+        Delegate to Archive::Extract
+=head1 METHODS
+
+=head2 $dir = _extract( module => $modobj, [perl => '/path/to/perl', extractdir => '/path/to/extract/to', prefer_bin => BOOL, verbose => BOOL, force => BOOL] )
+
+C<_extract> will take a module object and extract it to C<extractdir>
+if provided, or the default location which is obtained from your 
+config.
+
+The file name is obtained by looking at C<< $modobj->status->fetch >>
+and will be parsed to see if it's a tar or zip archive.
+
+If it's a zip archive, C<__unzip> will be called, otherwise C<__untar>
+will be called. In the unlikely event the file is of neither format,
+an error will be thrown.
+
+C<_extract> takes the following options:
+
+=over 4
+
+=item module
+
+A C<CPANPLUS::Module> object. This is required.
+
+=item extractdir
+
+The directory to extract the archive to. By default this looks 
+something like:
+    /CPANPLUS_BASE/PERL_VERSION/BUILD/MODULE_NAME
+
+=item prefer_bin
+
+A flag indicating whether you prefer a pure perl solution, ie
+C<Archive::Tar> or C<Archive::Zip> respectively, or a binary solution
+like C<unzip> and C<tar>.
+
+=item perl
+
+The path to the perl executable to use for any perl calls. Also used
+to determine the build version directory for extraction.
+
+=item verbose
+
+Specifies whether to be verbose or not. Defaults to your corresponding
+config entry.
+
+=item force
+
+Specifies whether to force the extraction or not. Defaults to your
+corresponding config entry.
+
+=back
+
+All other options are passed on verbatim to C<__unzip> or C<__untar>.
+
+Returns the directory the file was extracted to on success and false
+on failure.
+
+=cut
+
+sub _extract {
+    my $self = shift;
+    my $conf = $self->configure_object;
+    my %hash = @_;
+    
+    local $Params::Check::ALLOW_UNKNOWN = 1;
+    
+    my( $mod, $verbose, $force );
+    my $tmpl = {
+        force       => { default => $conf->get_conf('force'),   
+                            store => \$force },
+        verbose     => { default => $conf->get_conf('verbose'), 
+                            store => \$verbose },
+        prefer_bin  => { default => $conf->get_conf('prefer_bin') },
+        extractdir  => { default => $conf->get_conf('extractdir') },
+        module      => { required => 1, allow => IS_MODOBJ, store => \$mod },
+        perl        => { default => $^X },
+    };
+    
+    my $args = check( $tmpl, \%hash ) or return;
+    
+    ### did we already extract it ? ###
+    my $loc = $mod->status->extract();
+    
+    if( $loc && !$force ) {
+        msg(loc("Already extracted '%1' to '%2'. ".
+                "Won't extract again without force",
+                $mod->module, $loc), $verbose);
+        return $loc;
+    }
+
+    ### did we already fetch the file? ###
+    my $file = $mod->status->fetch();
+    unless( -s $file ) {
+        error( loc( "File '%1' has zero size: cannot extract", $file ) );    
+        return;
+    }
+
+    ### the dir to extract to ###
+    my $to =    $args->{'extractdir'} ||
+                File::Spec->catdir(
+                        $conf->get_conf('base'),
+                        $self->_perl_version( perl => $args->{'perl'} ),
+                        $conf->_get_build('moddir'),
+                );
+    ### delegate to Archive::Extract ###
+    ### set up some flags for archive::extract ###
+    local $Archive::Extract::PREFER_BIN = $args->{'prefer_bin'};
+    local $Archive::Extract::DEBUG      = $conf->get_conf('debug');
+    local $Archive::Extract::WARN       = $verbose;
+
+    my $ae = Archive::Extract->new( archive => $file );
+
+    unless( $ae->extract( to => $to ) ) {
+        error( loc( "Unable to extract '%1' to '%2': %3",
+                    $file, $to, $ae->error ) );
+        return;
+    }
+    
+    ### if ->files is not filled, we dont know what the hell was
+    ### extracted.. try to offer a suggestion and bail :(
+    unless ( $ae->files ) {
+        error( loc( "'%1' was not able to determine extracted ".
+                    "files from the archive. Instal '%2' and ensure ".
+                    "it works properly and try again",
+                    $ae->is_zip ? 'Archive::Zip' : 'Archive::Tar' ) );
+        return;                    
+    }                    
+    
+    
+    ### print out what files we extracted ###  
+    msg(loc("Extracted '%1'",$_),$verbose) for @{$ae->files};  
+    
+    ### set them all to be +w for the owner, so we don't get permission
+    ### denied for overwriting files that are just +r
+    
+    ### this is to rigurous -- just change to +w for the owner [cpan #13358] 
+    #chmod 0755, map { File::Spec->rel2abs( File::Spec->catdir($to, $_) ) }
+    #            @{$ae->files};
+    
+    for my $file ( @{$ae->files} ) { 
+        my $path = File::Spec->rel2abs( File::Spec->catdir($to, $file) );
+    
+        $self->_mode_plus_w( file => $path );
+    }
+    
+    ### check the return value for the extracted path ###
+    ### Make an educated guess if we didn't get an extract_path
+    ### back
+    ### XXX apparently some people make their own dists and they 
+    ### pack up '.' which means the leading directory is '.' 
+    ### and only the second directory is the actual module directory
+    ### so, we'll have to check if our educated guess exists first, 
+    ### then see if the extract path works.. and if nothing works...
+    ### well, then we really don't know.
+
+    my $dir;
+    for my $try ( File::Spec->rel2abs( File::Spec->catdir(   
+                    $to, $mod->package_name .'-'. $mod->package_version ) ),
+                  File::Spec->rel2abs( $ae->extract_path ),
+    ) {
+        ($dir = $try) && last if -d $try;
+    }
+                                            
+    ### test if the dir exists ###
+    unless( $dir && -d $dir ) {
+        error(loc("Unable to determine extract dir for '%1'",$mod->module));
+        return;
+    
+    } else {    
+        msg(loc("Extracted '%1' to '%2'", $mod->module, $dir), $verbose);
+        
+        ### register where we extracted the files to,
+        ### also store what files were extracted
+        $mod->status->extract( $dir ); 
+        $mod->status->files( $ae->files );
+    }
+      
+    ### also, figure out what kind of install we're dealing with ###
+    $mod->get_installer_type();
+
+    return $mod->status->extract();
+}
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/CPANPLUS/Internals/Fetch.pm b/lib/CPANPLUS/Internals/Fetch.pm
new file mode 100644 (file)
index 0000000..b8ad371
--- /dev/null
@@ -0,0 +1,372 @@
+package CPANPLUS::Internals::Fetch;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use File::Fetch;
+use File::Spec;
+use Cwd                         qw[cwd];
+use IPC::Cmd                    qw[run];
+use Params::Check               qw[check];
+use Module::Load::Conditional   qw[can_load];
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+
+$Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Internals::Fetch
+
+=head1 SYNOPSIS
+
+    my $output = $cb->_fetch(
+                        module      => $modobj,
+                        fetchdir    => '/path/to/save/to',
+                        verbose     => BOOL,
+                        force       => BOOL,
+                    );
+
+    $cb->_add_fail_host( host => 'foo.com' );
+    $cb->_host_ok(       host => 'foo.com' );
+
+
+=head1 DESCRIPTION
+
+CPANPLUS::Internals::Fetch fetches files from either ftp, http, file
+or rsync mirrors.
+
+This is the rough flow:
+
+    $cb->_fetch
+        Delegate to File::Fetch;
+
+
+=head1 METHODS
+
+=cut
+
+=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL] )
+
+C<_fetch> will fetch files based on the information in a module
+object. You always need a module object. If you want a fake module
+object for a one-off fetch, look at C<CPANPLUS::Module::Fake>.
+
+C<fetchdir> is the place to save the file to. Usually this
+information comes from your configuration, but you can override it
+expressly if needed.
+
+C<fetch_from> lets you specify an URI to get this file from. If you
+do not specify one, your list of configured hosts will be probed to
+download the file from.
+
+C<force> forces a new download, even if the file already exists.
+
+C<verbose> simply indicates whether or not to print extra messages.
+
+C<prefer_bin> indicates whether you prefer the use of commandline
+programs over perl modules. Defaults to your corresponding config
+setting.
+
+C<_fetch> figures out, based on the host list, what scheme to use and
+from there, delegates to C<File::Fetch> do the actual fetching.
+
+Returns the path of the output file on success, false on failure.
+
+Note that you can set a C<blacklist> on certain methods in the config.
+Simply add the identifying name of the method (ie, C<lwp>) to:
+    $conf->_set_fetch( blacklist => ['lwp'] );
+
+And the C<LWP> function will be skipped by C<File::Fetch>.
+
+=cut
+
+sub _fetch {
+    my $self = shift;
+    my $conf = $self->configure_object;
+    my %hash = @_;
+
+    local $Params::Check::NO_DUPLICATES = 0;
+
+    my ($modobj, $verbose, $force, $fetch_from);
+    my $tmpl = {
+        module      => { required => 1, allow => IS_MODOBJ, store => \$modobj },
+        fetchdir    => { default => $conf->get_conf('fetchdir') },
+        fetch_from  => { default => '', store => \$fetch_from },
+        force       => { default => $conf->get_conf('force'),
+                            store => \$force },
+        verbose     => { default => $conf->get_conf('verbose'),
+                            store => \$verbose },
+        prefer_bin  => { default => $conf->get_conf('prefer_bin') },
+    };
+
+
+    my $args = check( $tmpl, \%hash ) or return;
+
+    ### check if we already downloaded the thing ###
+    if( (my $where = $modobj->status->fetch()) && !$force ) {
+        msg(loc("Already fetched '%1' to '%2', " .
+                "won't fetch again without force",
+                $modobj->module, $where ), $verbose );
+        return $where;
+    }
+
+    my ($remote_file, $local_file, $local_path);
+
+    ### build the local path to downlaod to ###
+    {
+        $local_path =   $args->{fetchdir} ||
+                        File::Spec->catdir(
+                            $conf->get_conf('base'),
+                            $modobj->path,
+                        );
+
+        ### create the path if it doesn't exist ###
+        unless( -d $local_path ) {
+            unless( $self->_mkdir( dir => $local_path ) ) {
+                msg( loc("Could not create path '%1'", $local_path), $verbose);
+                return;
+            }
+        }
+
+        $local_file = File::Spec->rel2abs(
+                        File::Spec->catfile(
+                                    $local_path,
+                                    $modobj->package,
+                        )
+                    );
+    }
+
+    ### do we already have the file? ###
+    if( -e $local_file ) {
+
+        if( $args->{force} ) {
+
+            ### some fetches will fail if the files exist already, so let's
+            ### delete them first
+            unlink $local_file
+                or msg( loc("Could not delete %1, some methods may " .
+                            "fail to force a download", $local_file), $verbose);
+         } else {
+
+            ### store where we fetched it ###
+            $modobj->status->fetch( $local_file );
+
+            return $local_file;
+        }
+    }
+
+
+    ### we got a custom URI 
+    if ( $fetch_from ) {
+        my $abs = $self->__file_fetch(  from    => $fetch_from,
+                                        to      => $local_path,
+                                        verbose => $verbose );
+                                        
+        unless( $abs ) {
+            error(loc("Unable to download '%1'", $fetch_from));
+            return;
+        }            
+
+        ### store where we fetched it ###
+        $modobj->status->fetch( $abs );
+
+        return $abs;
+
+    ### we will get it from one of our mirrors
+    } else {
+        ### build the remote path to download from ###
+        {   $remote_file = File::Spec::Unix->catfile(
+                                        $modobj->path,
+                                        $modobj->package,
+                                    );
+            unless( $remote_file ) {
+                error( loc('No remote file given for download') );
+                return;
+            }
+        }
+    
+        ### see if we even have a host or a method to use to download with ###
+        my $found_host;
+        my @maybe_bad_host;
+    
+        HOST: {
+            ### F*CKING PIECE OF F*CKING p4 SHIT makes 
+            ### '$File :: Fetch::SOME_VAR'
+            ### into a meta variable and starts substituting the file name...
+            ### GRAAAAAAAAAAAAAAAAAAAAAAH!
+            ### use ' to combat it!
+    
+            ### set up some flags for File::Fetch ###
+            local $File'Fetch::BLACKLIST    = $conf->_get_fetch('blacklist');
+            local $File'Fetch::TIMEOUT      = $conf->get_conf('timeout');
+            local $File'Fetch::DEBUG        = $conf->get_conf('debug');
+            local $File'Fetch::FTP_PASSIVE  = $conf->get_conf('passive');
+            local $File'Fetch::FROM_EMAIL   = $conf->get_conf('email');
+            local $File'Fetch::PREFER_BIN   = $conf->get_conf('prefer_bin');
+            local $File'Fetch::WARN         = $verbose;
+    
+    
+            ### loop over all hosts we have ###
+            for my $host ( @{$conf->get_conf('hosts')} ) {
+                $found_host++;
+    
+                my $mirror_path = File::Spec::Unix->catfile(
+                                        $host->{'path'}, $remote_file
+                                    );
+    
+                ### build pretty print uri ###
+                my $where;
+                if( $host->{'scheme'} eq 'file' ) {
+                    $where = CREATE_FILE_URI->(
+                                File::Spec::Unix->rel2abs(
+                                    File::Spec::Unix->catdir(
+                                        grep { defined $_ && length $_ }
+                                        $host->{'host'},
+                                        $mirror_path
+                                     )
+                                )
+                            );
+                } else {
+                    my %args = ( scheme => $host->{scheme},
+                                 host   => $host->{host},
+                                 path   => $mirror_path,
+                                );
+                    
+                    $where = $self->_host_to_uri( %args );
+                }
+    
+                my $abs = $self->__file_fetch(  from    => $where, 
+                                                to      => $local_path,
+                                                verbose => $verbose );    
+                
+                ### we got a path back?
+                if( $abs ) {
+                    ### store where we fetched it ###
+                    $modobj->status->fetch( $abs );
+        
+                    ### this host is good, the previous ones are apparently
+                    ### not, so mark them as such.
+                    $self->_add_fail_host( host => $_ ) for @maybe_bad_host;
+                        
+                    return $abs;
+                }
+                
+                ### so we tried to get the file but didn't actually fetch it --
+                ### there's a chance this host is bad. mark it as such and 
+                ### actually flag it back if we manage to get the file 
+                ### somewhere else
+                push @maybe_bad_host, $host;
+            }
+        }
+    
+        $found_host
+            ? error(loc("Fetch failed: host list exhausted " .
+                        "-- are you connected today?"))
+            : error(loc("No hosts found to download from " .
+                        "-- check your config"));
+    }
+    
+    return;
+}
+
+sub __file_fetch {
+    my $self = shift;
+    my $conf = $self->configure_object;
+    my %hash = @_;
+
+    my ($where, $local_path, $verbose);
+    my $tmpl = {
+        from    => { required   => 1, store => \$where },
+        to      => { required   => 1, store => \$local_path },
+        verbose => { default    => $conf->get_conf('verbose'),
+                     store      => \$verbose },
+    };
+    
+    check( $tmpl, \%hash ) or return;
+
+    msg(loc("Trying to get '%1'", $where ), $verbose );
+
+    ### build the object ###
+    my $ff = File::Fetch->new( uri => $where );
+
+    ### sanity check ###
+    error(loc("Bad uri '%1'",$where)), return unless $ff;
+
+    if( my $file = $ff->fetch( to => $local_path ) ) {
+        unless( -e $file && -s _ ) {
+            msg(loc("'%1' said it fetched '%2', but it was not created",
+                    'File::Fetch', $file), $verbose);
+
+        } else {
+            my $abs = File::Spec->rel2abs( $file );
+            return $abs;
+        }
+
+    } else {
+        error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
+    }
+
+    return;
+}
+
+=pod
+
+=head2 _add_fail_host( host => $host_hashref )
+
+Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch>
+skip it in fetches until this cache is flushed.
+
+=head2 _host_ok( host => $host_hashref )
+
+Query the cache to see if this host is ok, or if it has been flagged
+as bad.
+
+Returns true if the host is ok, false otherwise.
+
+=cut
+
+{   ### caching functions ###
+
+    sub _add_fail_host {
+        my $self = shift;
+        my %hash = @_;
+
+        my $host;
+        my $tmpl = {
+            host => { required      => 1, default   => {},
+                      strict_type   => 1, store     => \$host },
+        };
+
+        check( $tmpl, \%hash ) or return;
+
+        return $self->_hosts->{$host} = 1;
+    }
+
+    sub _host_ok {
+        my $self = shift;
+        my %hash = @_;
+
+        my $host;
+        my $tmpl = {
+            host => { required => 1, store => \$host },
+        };
+
+        check( $tmpl, \%hash ) or return;
+
+        return $self->_hosts->{$host} ? 0 : 1;
+    }
+}
+
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/lib/CPANPLUS/Internals/Report.pm b/lib/CPANPLUS/Internals/Report.pm
new file mode 100644 (file)
index 0000000..ffcb4f0
--- /dev/null
@@ -0,0 +1,609 @@
+package CPANPLUS::Internals::Report;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Internals::Constants::Report;
+
+use Data::Dumper;
+
+use Params::Check               qw[check];
+use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
+use Module::Load::Conditional   qw[can_load];
+
+$Params::Check::VERBOSE = 1;
+
+### for the version ###
+require CPANPLUS::Internals;
+
+=head1 NAME
+
+CPANPLUS::Internals::Report
+
+=head1 SYNOPSIS
+
+  ### enable test reporting
+  $cb->configure_object->set_conf( cpantest => 1 );
+    
+  ### set custom mx host, shouldn't normally be needed
+  $cb->configure_object->set_conf( cpantest_mx => 'smtp.example.com' );
+
+=head1 DESCRIPTION
+
+This module provides all the functionality to send test reports to
+C<http://testers.cpan.org> using the C<Test::Reporter> module.
+
+All methods will be called automatically if you have C<CPANPLUS>
+configured to enable test reporting (see the C<SYNOPSIS>).
+
+=head1 METHODS
+
+=head2 $bool = $cb->_have_query_report_modules
+
+This function checks if all the required modules are here for querying
+reports. It returns true and loads them if they are, or returns false
+otherwise.
+
+=head2 $bool = $cb->_have_send_report_modules
+
+This function checks if all the required modules are here for sending
+reports. It returns true and loads them if they are, or returns false
+otherwise.
+
+=cut
+{   my $query_list = {
+        LWP              => '0.0',
+        'LWP::UserAgent' => '0.0',
+        'HTTP::Request'  => '0.0',
+        URI              => '0.0',
+        YAML             => '0.0',
+    };
+
+    my $send_list = {
+        %$query_list,
+        'Test::Reporter' => 1.27,
+    };
+
+    sub _have_query_report_modules {
+        my $self = shift;
+        my $conf = $self->configure_object;
+        my %hash = @_;
+
+        my $tmpl = {
+            verbose => { default => $conf->get_conf('verbose') },
+        };
+
+        my $args = check( $tmpl, \%hash ) or return;
+
+        return can_load( modules => $query_list, verbose => $args->{verbose} )
+                ? 1
+                : 0;
+    }
+
+    sub _have_send_report_modules {
+        my $self = shift;
+        my $conf = $self->configure_object;
+        my %hash = @_;
+
+        my $tmpl = {
+            verbose => { default => $conf->get_conf('verbose') },
+        };
+
+        my $args = check( $tmpl, \%hash ) or return;
+
+        return can_load( modules => $send_list, verbose => $args->{verbose} )
+                ? 1
+                : 0;
+    }
+}
+
+=head2 @list = $cb->_query_report( module => $modobj, [all_versions => BOOL, verbose => BOOL] )
+
+This function queries the CPAN testers database at
+I<http://testers.cpan.org/> for test results of specified module objects,
+module names or distributions.
+
+The optional argument C<all_versions> controls whether all versions of
+a given distribution should be grabbed.  It defaults to false
+(fetching only reports for the current version).
+
+Returns the a list with the following data structures (for CPANPLUS
+version 0.042) on success, or false on failure:
+
+          {
+            'grade' => 'PASS',
+            'dist' => 'CPANPLUS-0.042',
+            'platform' => 'i686-pld-linux-thread-multi'
+          },
+          {
+            'grade' => 'PASS',
+            'dist' => 'CPANPLUS-0.042',
+            'platform' => 'i686-linux-thread-multi'
+          },
+          {
+            'grade' => 'FAIL',
+            'dist' => 'CPANPLUS-0.042',
+            'platform' => 'cygwin-multi-64int',
+            'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371'
+          },
+          {
+            'grade' => 'FAIL',
+            'dist' => 'CPANPLUS-0.042',
+            'platform' => 'i586-linux',
+            'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396'
+          },
+
+The status of the test can be one of the following:
+UNKNOWN, PASS, FAIL or NA (not applicable).
+
+=cut
+
+sub _query_report {
+    my $self = shift;
+    my $conf = $self->configure_object;
+    my %hash = @_;
+
+    my($mod, $verbose, $all);
+    my $tmpl = {
+        module          => { required => 1, allow => IS_MODOBJ,
+                                store => \$mod },
+        verbose         => { default => $conf->get_conf('verbose'),
+                                store => \$verbose },
+        all_versions    => { default => 0, store => \$all },
+    };
+
+    check( $tmpl, \%hash ) or return;
+
+    ### check if we have the modules we need for querying
+    return unless $self->_have_query_report_modules( verbose => 1 );
+
+    ### new user agent ###
+    my $ua = LWP::UserAgent->new;
+    $ua->agent( CPANPLUS_UA->() );
+
+    ### set proxies if we have them ###
+    $ua->env_proxy();
+
+    my $url = TESTERS_URL->($mod->package_name);
+    my $req = HTTP::Request->new( GET => $url);
+
+    msg( loc("Fetching: '%1'", $url), $verbose );
+
+    my $res = $ua->request( $req );
+
+    unless( $res->is_success ) {
+        error( loc( "Fetching report for '%1' failed: %2",
+                    $url, $res->message ) );
+        return;
+    }
+
+    my $aref = YAML::Load( $res->content );
+
+    my $dist = $mod->package_name .'-'. $mod->package_version;
+
+    my @rv;
+    for my $href ( @$aref ) {
+        next unless $all or defined $href->{'distversion'} && 
+                            $href->{'distversion'} eq $dist;
+
+        push @rv, { platform    => $href->{'platform'},
+                    grade       => $href->{'action'},
+                    dist        => $href->{'distversion'},
+                    ( $href->{'action'} eq 'FAIL'
+                        ? (details => TESTERS_DETAILS_URL->($mod->package_name))
+                        : ()
+                    ) };
+    }
+
+    return @rv if @rv;
+    return;
+}
+
+=pod
+
+=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, dontcc => BOOL, verbose => BOOL, force => BOOL]);
+
+This function sends a testers report to C<cpan-testers@perl.org> for a
+particular distribution.
+It returns true on success, and false on failure.
+
+It takes the following options:
+
+=over 4
+
+=item module
+
+The module object of this particular distribution
+
+=item buffer
+
+The output buffer from the 'make/make test' process
+
+=item failed
+
+Boolean indicating if the 'make/make test' went wrong
+
+=item save
+
+Boolean indicating if the report should be saved locally instead of
+mailed out. If provided, this function will return the location the
+report was saved to, rather than a simple boolean 'TRUE'.
+
+Defaults to false.
+
+=item address
+
+The email address to mail the report for. You should never need to
+override this, but it might be useful for debugging purposes.
+
+Defaults to C<cpan-testers@perl.org>.
+
+=item dontcc
+
+Boolean indicating whether or not we should Cc: the author. If false,
+previous error reports are inspected and checked if the author should
+be mailed. If set to true, these tests are skipped and the author is
+definitely not Cc:'d.
+You should probably not change this setting.
+
+Defaults to false.
+
+=item verbose
+
+Boolean indicating on whether or not to be verbose.
+
+Defaults to your configuration settings
+
+=item force
+
+Boolean indicating whether to force the sending, even if the max
+amount of reports for fails have already been reached, or if you
+may already have sent it before.
+
+Defaults to your configuration settings
+
+=back
+
+=cut
+
+sub _send_report {
+    my $self = shift;
+    my $conf = $self->configure_object;
+    my %hash = @_;
+
+    ### do you even /have/ test::reporter? ###
+    unless( $self->_have_send_report_modules(verbose => 1) ) {
+        error( loc( "You don't have '%1' (or modules required by '%2') ".
+                    "installed, you cannot report test results.",
+                    'Test::Reporter', 'Test::Reporter' ) );
+        return;
+    }
+
+    ### check arguments ###
+    my ($buffer, $failed, $mod, $verbose, $force, $address, $save, $dontcc,
+        $tests_skipped );
+    my $tmpl = {
+            module  => { required => 1, store => \$mod, allow => IS_MODOBJ },
+            buffer  => { required => 1, store => \$buffer },
+            failed  => { required => 1, store => \$failed },
+            address => { default  => CPAN_TESTERS_EMAIL, store => \$address },
+            save    => { default  => 0, store => \$save },
+            dontcc  => { default  => 0, store => \$dontcc },
+            verbose => { default  => $conf->get_conf('verbose'),
+                            store => \$verbose },
+            force   => { default  => $conf->get_conf('force'),
+                            store => \$force },
+            tests_skipped   
+                    => { default => 0, store => \$tests_skipped },
+    };
+
+    check( $tmpl, \%hash ) or return;
+
+    ### get the data to fill the email with ###
+    my $name    = $mod->module;
+    my $dist    = $mod->package_name . '-' . $mod->package_version;
+    my $author  = $mod->author->author;
+    my $email   = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author );
+    my $cp_conf = $conf->get_conf('cpantest') || '';
+    my $int_ver = $CPANPLUS::Internals::VERSION;
+    my $cb      = $mod->parent;
+
+
+    ### determine the grade now ###
+
+    my $grade;
+    ### check if this is a platform specific module ###
+    ### if we failed the test, there may be reasons why 
+    ### an 'NA' might have to be insted
+    GRADE: { if ( $failed ) {
+        
+
+        ### XXX duplicated logic between this block
+        ### and REPORTED_LOADED_PREREQS :(
+        
+        ### figure out if the prereqs are on CPAN at all
+        ### -- if not, send NA grade
+        ### Also, if our version of prereqs is too low,
+        ### -- send NA grade.
+        ### This is to address bug: #25327: do not count 
+        ### as FAIL modules where prereqs are not filled
+        {   my $prq = $mod->status->prereqs || {};
+        
+            while( my($prq_name,$prq_ver) = each %$prq ) {
+                my $obj = $cb->module_tree( $prq_name );
+                
+                unless( $obj ) {
+                    msg(loc( "Prerequisite '%1' for '%2' could not be obtained".
+                             " from CPAN -- sending N/A grade", 
+                             $prq_name, $name ), $verbose );
+
+                    $grade = GRADE_NA;
+                    last GRADE;        
+                }
+
+                if( $cb->_vcmp( $prq_ver, $obj->installed_version ) > 0 ) {
+                    msg(loc( "Installed version of '%1' ('%2') is too low for ".
+                             "'%3' (needs '%4') -- sending N/A grade", 
+                             $prq_name, $obj->installed_version, 
+                             $name, $prq_ver ), $verbose );
+                             
+                    $grade = GRADE_NA;
+                    last GRADE;        
+                }                             
+            }
+        }
+        
+        unless( RELEVANT_TEST_RESULT->($mod) ) {
+            msg(loc(
+                "'%1' is a platform specific module, and the test results on".
+                " your platform are not relevant --sending N/A grade.",
+                $name), $verbose);
+        
+            $grade = GRADE_NA;
+        
+        } elsif ( UNSUPPORTED_OS->( $buffer ) ) {
+            msg(loc(
+                "'%1' is a platform specific module, and the test results on".
+                " your platform are not relevant --sending N/A grade.",
+                $name), $verbose);
+        
+            $grade = GRADE_NA;
+        
+        ### you dont have a high enough perl version?    
+        } elsif ( PERL_VERSION_TOO_LOW->( $buffer ) ) {
+            msg(loc("'%1' requires a higher version of perl than your current ".
+                    "version -- sending N/A grade.", $name), $verbose);
+        
+            $grade = GRADE_NA;                
+
+        ### perhaps where were no tests...
+        ### see if the thing even had tests ###
+        } elsif ( NO_TESTS_DEFINED->( $buffer ) ) {
+            $grade = GRADE_UNKNOWN;
+
+        } else {
+            
+            $grade = GRADE_FAIL;
+        }
+
+    ### if we got here, it didn't fail and tests were present.. so a PASS
+    ### is in order
+    } else {
+        $grade = GRADE_PASS;
+    } }
+
+    ### so an error occurred, let's see what stage it went wrong in ###
+    my $message;
+    if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) {
+
+        ### return if one or more missing external libraries
+        if( my @missing = MISSING_EXTLIBS_LIST->($buffer) ) {
+            msg(loc("Not sending test report - " .
+                    "external libraries not pre-installed"));
+            return 1;
+        }
+
+        ### will be 'fetch', 'make', 'test', 'install', etc ###
+        my $stage   = TEST_FAIL_STAGE->($buffer);
+
+        ### return if we're only supposed to report make_test failures ###
+        return 1 if $cp_conf =~  /\bmaketest_only\b/i
+                    and ($stage !~ /\btest\b/);
+
+        ### the header
+        $message =  REPORT_MESSAGE_HEADER->( $int_ver, $author );
+
+        ### the bit where we inform what went wrong
+        $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );
+
+        ### was it missing prereqs? ###
+        if( my @missing = MISSING_PREREQS_LIST->($buffer) ) {
+            if(!$self->_verify_missing_prereqs(
+                                module  => $mod,
+                                missing => \@missing
+                        )) {
+                msg(loc("Not sending test report - "  .
+                        "bogus missing prerequisites report"));
+                return 1;
+            }
+            $message .= REPORT_MISSING_PREREQS->($author,$email,@missing);
+        }
+
+        ### was it missing test files? ###
+        if( NO_TESTS_DEFINED->($buffer) ) {
+            $message .= REPORT_MISSING_TESTS->();
+        }
+
+        ### add a list of what modules have been loaded of your prereqs list
+        $message .= REPORT_LOADED_PREREQS->($mod);
+
+        ### the footer
+        $message .=  REPORT_MESSAGE_FOOTER->();
+
+    ### it may be another grade than fail/unknown.. may be worth noting
+    ### that tests got skipped, since the buffer is not added in
+    } elsif ( $tests_skipped ) {
+        $message .= REPORT_TESTS_SKIPPED->();
+    }        
+
+    ### if it failed, and that already got reported, we're not cc'ing the
+    ### author. Also, 'dont_cc' might be in the config, so check this;
+    my $dont_cc_author = $dontcc;
+
+    unless( $dont_cc_author ) {
+        if( $cp_conf =~ /\bdont_cc\b/i ) {
+            $dont_cc_author++;
+
+        } elsif ( $grade eq GRADE_PASS ) {
+            $dont_cc_author++
+
+        } elsif( $grade eq GRADE_FAIL ) {
+            my @already_sent =
+                $self->_query_report( module => $mod, verbose => $verbose );
+
+            ### if we can't fetch it, we'll just assume no one
+            ### mailed him yet
+            my $count = 0;
+            if( @already_sent ) {
+                for my $href (@already_sent) {
+                    $count++ if uc $href->{'grade'} eq uc GRADE_FAIL;
+                }
+            }
+
+            if( $count > MAX_REPORT_SEND and !$force) {
+                msg(loc("'%1' already reported for '%2', ".
+                        "not cc-ing the author",
+                        GRADE_FAIL, $dist ), $verbose );
+                $dont_cc_author++;
+            }
+        }
+    }
+
+    ### reporter object ###
+    my $reporter = Test::Reporter->new(
+                        grade           => $grade,
+                        distribution    => $dist,
+                        via             => "CPANPLUS $int_ver",
+                        debug           => $conf->get_conf('debug'),
+                    );
+                    
+    ### set a custom mx, if requested
+    $reporter->mx( [ $conf->get_conf('cpantest_mx') ] ) 
+        if $conf->get_conf('cpantest_mx');
+
+    ### set the from address ###
+    $reporter->from( $conf->get_conf('email') )
+        if $conf->get_conf('email') !~ /\@example\.\w+$/i;
+
+    ### give the user a chance to programattically alter the message
+    $message = $self->_callbacks->munge_test_report->($mod, $message, $grade);
+
+    ### add the body if we have any ###
+    $reporter->comments( $message ) if defined $message && length $message;
+
+    ### do a callback to ask if we should send the report
+    unless ($self->_callbacks->send_test_report->($mod, $grade)) {
+        msg(loc("Ok, not sending test report"));
+        return 1;
+    }
+
+    ### do a callback to ask if we should edit the report
+    if ($self->_callbacks->edit_test_report->($mod, $grade)) {
+        ###&nb