summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm1330
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Backend/RV.pm144
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Config.pm797
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm630
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm1653
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm688
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Autobundle.pm117
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Base.pm261
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build.pm836
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build/Constants.pm69
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Dist/MM.pm1007
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Sample.pm16
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Error.pm201
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/FAQ.pod30
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Hacking.pod135
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals.pm516
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm375
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm407
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm243
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm473
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm645
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm363
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm1417
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm374
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm326
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm145
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm657
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils/Autoflush.pm5
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm1815
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm232
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm80
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm251
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm86
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm65
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm547
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Shell.pm341
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Classic.pm1236
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm1938
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm201
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod136
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm186
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Source.pm107
42 files changed, 21081 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm
new file mode 100644
index 00000000000..a599e5429eb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend.pm
@@ -0,0 +1,1330 @@
+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 File::Basename ();
+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 } @_) {
+
+ ### From John Malmberg: This is failing on VMS
+ ### because ODS-2 does not retain the case of
+ ### filenames that are created.
+ ### The problem is the filename is being converted
+ ### to a module name and then looked up in the
+ ### %$modtree hash.
+ ###
+ ### As a fix, we do a search on VMS instead --
+ ### more cpu cycles, but it gets around the case
+ ### problem --kane
+ my ($modobj) = do {
+ ON_VMS
+ ? $self->search(
+ type => 'module',
+ allow => [qr/^$name$/i],
+ )
+ : $modtree->{$name}
+ };
+
+ push @rv, $modobj || '';
+ }
+ 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 = @_;
+
+ my ($type);
+ my $args = do {
+ local $Params::Check::NO_DUPLICATES = 0;
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ type => { required => 1, allow => [CPANPLUS::Module->accessors(),
+ CPANPLUS::Module::Author->accessors()], store => \$type },
+ allow => { required => 1, default => [ ], strict_type => 1 },
+ };
+
+ 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 = @_;
+
+ my ($mods);
+ my $args = do {
+ local $Params::Check::NO_DUPLICATES = 1;
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ modules => { default => [], strict_type => 1,
+ required => 1, store => \$mods },
+ };
+
+ 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|URI|PATH )
+
+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
+
+=item /tmp/Text-Bastardize-1.06
+
+=item ./Text-Bastardize-1.06
+
+=item .
+
+=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.
+
+The last three are examples of PATH resolution. In the first, we supply
+an absolute path to the unwrapped distribution. In the second the
+distribution is relative to the current working directory.
+In the third, we will use the current working directory.
+
+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 );
+ }
+
+ ### Special case arbitary file paths such as '.' etc.
+ if ( $mod and -d File::Spec->rel2abs($mod) ) {
+ my $dir = File::Spec->rel2abs($mod);
+ my $parent = File::Spec->rel2abs( File::Spec->catdir( $dir, '..' ) );
+
+ ### fix paths on VMS
+ if (ON_VMS) {
+ $dir = VMS::Filespec::unixify($dir);
+ $parent = VMS::Filespec::unixify($parent);
+ }
+
+ my $dist = $mod = File::Basename::basename($dir);
+ $dist .= '-0' unless $dist =~ /\-[0-9._]+$/;
+ $dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
+
+ my $modobj = CPANPLUS::Module::Fake->new(
+ module => $mod,
+ version => 0,
+ package => $dist,
+ path => $parent,
+ author => CPANPLUS::Module::Author::Fake->new
+ );
+
+ ### better guess for the version
+ $modobj->version( $modobj->package_version )
+ if defined $modobj->package_version;
+
+ ### better guess at module name, if possible
+ if ( my $pkgname = $modobj->package_name ) {
+ $pkgname =~ s/-/::/g;
+
+ ### no sense replacing it unless we changed something
+ $modobj->module( $pkgname )
+ if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
+ }
+
+ $modobj->status->fetch( $parent );
+ $modobj->status->extract( $dir );
+ $modobj->get_installer_type;
+ return $modobj;
+ }
+
+ ### 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 );
+
+ ### better guess for the version
+ $modobj->version( $modobj->package_version )
+ if defined $modobj->package_version;
+
+ ### better guess at module name, if possible
+ if ( my $pkgname = $modobj->package_name ) {
+ $pkgname =~ s/-/::/g;
+
+ ### no sense replacing it unless we changed something
+ $modobj->module( $pkgname )
+ if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
+ }
+
+ return $modobj;
+ }
+
+ ### 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, $full) =
+ $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,
+ ### no extension? use the extension the original package
+ ### had instead
+ package => do { $ext
+ ? $full
+ : $full .'.'. $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 {
+
+ # Lets not give up too easily. There is one last chance
+ # http://perlmonks.org/?node_id=805957
+ # This should catch edge-cases where the package name
+ # is unrelated to the modules it contains.
+
+ my ($modobj) = grep { $_->package_name eq $mod }
+ $self->search( type => 'package', allow => [ qr/^\Q$mod\E/ ], );
+ return $modobj if IS_MODOBJ->( module => $modobj );
+
+ 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. You can disable fetching of the
+index files if you don't plan to use the local mirror as your primary
+site, or if you'd like up-to-date index files be fetched from elsewhere.
+
+Defaults to true.
+
+=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 by issuing the following commands:
+
+ ### using the default shell:
+ CPAN Terminal> i file://path/to/Snapshot_XXYY.pm
+
+ ### using the API
+ $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' );
+ $modobj->install;
+
+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;
+ }
+
+ ### make sure we load the module tree *before* doing this, as it
+ ### starts to chdir all over the place
+ $self->module_tree;
+
+ my $string = join "\n\n",
+ map {
+ 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
+
+To install the modules from this snapshot, run:
+
+ cpanp -i file://full/path/to/${name}.pm
+
+$head CONTENTS
+
+$string
+
+$head CONFIGURATION
+
+$perl_v
+
+$head AUTHOR
+
+This bundle has been generated autotomatically by
+ $pkg $version
+
+EOF
+
+ close $fh;
+
+ return $file;
+}
+
+=head2 $bool = $cb->save_state
+
+Explicit command to save memory state to disk. This can be used to save
+information to disk about where a module was extracted, the result of
+C<make test>, etc. This will then be re-loaded into memory when a new
+session starts.
+
+The capability of saving state to disk depends on the source engine
+being used (See C<CPANPLUS::Config> for the option to choose your
+source engine). The default storage engine supports this option.
+
+Most users will not need this command, but it can handy for automated
+systems like setting up CPAN smoke testers.
+
+The method will return true if it managed to save the state to disk,
+or false if it did not.
+
+=cut
+
+sub save_state {
+ my $self = shift;
+ return $self->_save_state( @_ );
+}
+
+
+### XXX these wrappers are not individually tested! only the underlying
+### code through source.t and indirectly trought he CustomSource plugin.
+=pod
+
+=head1 CUSTOM MODULE SOURCES
+
+Besides the sources as provided by the general C<CPAN> mirrors, it's
+possible to add your own sources list to your C<CPANPLUS> index.
+
+The methodology behind this works much like C<Debian's apt-sources>.
+
+The methods below show you how to make use of this functionality. Also
+note that most of these methods are available through the default shell
+plugin command C</cs>, making them available as shortcuts through the
+shell and via the commandline.
+
+=head2 %files = $cb->list_custom_sources
+
+Returns a mapping of registered custom sources and their local indices
+as follows:
+
+ /full/path/to/local/index => http://remote/source
+
+Note that any file starting with an C<#> is being ignored.
+
+=cut
+
+sub list_custom_sources {
+ return shift->__list_custom_module_sources( @_ );
+}
+
+=head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] );
+
+Adds an C<URI> to your own sources list and mirrors its index. See the
+documentation on C<< $cb->update_custom_source >> on how this is done.
+
+Returns the full path to the local index on success, or false on failure.
+
+Note that when adding a new C<URI>, the change to the in-memory tree is
+not saved until you rebuild or save the tree to disk again. You can do
+this using the C<< $cb->reload_indices >> method.
+
+=cut
+
+sub add_custom_source {
+ return shift->_add_custom_module_source( @_ );
+}
+
+=head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] );
+
+Removes an C<URI> from your own sources list and removes its index.
+
+To find out what C<URI>s you have as part of your own sources list, use
+the C<< $cb->list_custom_sources >> method.
+
+Returns the full path to the deleted local index file on success, or false
+on failure.
+
+=cut
+
+### XXX do clever dispatching based on arg number?
+sub remove_custom_source {
+ return shift->_remove_custom_module_source( @_ );
+}
+
+=head2 $bool = $cb->update_custom_source( [remote => URI] );
+
+Updates the indexes for all your custom sources. It does this by fetching
+a file called C<packages.txt> in the root of the custom sources's C<URI>.
+If you provide the C<remote> argument, it will only update the index for
+that specific C<URI>.
+
+Here's an example of how custom sources would resolve into index files:
+
+ file:///path/to/sources => file:///path/to/sources/packages.txt
+ http://example.com/sources => http://example.com/sources/packages.txt
+ ftp://example.com/sources => ftp://example.com/sources/packages.txt
+
+The file C<packages.txt> simply holds a list of packages that can be found
+under the root of the C<URI>. This file can be automatically generated for
+you when the remote source is a C<file:// URI>. For C<http://>, C<ftp://>,
+and similar, the administrator of that repository should run the method
+C<< $cb->write_custom_source_index >> on the repository to allow remote
+users to index it.
+
+For details, see the C<< $cb->write_custom_source_index >> method below.
+
+All packages that are added via this mechanism will be attributed to the
+author with C<CPANID> C<LOCAL>. You can use this id to search for all
+added packages.
+
+=cut
+
+sub update_custom_source {
+ my $self = shift;
+
+ ### if it mentions /remote/, the request is to update a single uri,
+ ### not all the ones we have, so dispatch appropriately
+ my $rv = grep( /remote/i, @_)
+ ? $self->__update_custom_module_source( @_ )
+ : $self->__update_custom_module_sources( @_ );
+
+ return $rv;
+}
+
+=head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] );
+
+Writes the index for a custom repository root. Most users will not have to
+worry about this, but administrators of a repository will need to make sure
+their indexes are up to date.
+
+The index will be written to a file called C<packages.txt> in your repository
+root, which you can specify with the C<path> argument. You can override this
+location by specifying the C<to> argument, but in normal operation, that should
+not be required.
+
+Once the index file is written, users can then add the C<URI> pointing to
+the repository to their custom list of sources and start using it right away. See the C<< $cb->add_custom_source >> method for user details.
+
+=cut
+
+sub write_custom_source_index {
+ return shift->__write_custom_module_index( @_ );
+}
+
+1;
+
+=pod
+
+=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>,
+L<CPANPLUS::Selfupdate>
+
+=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/Master/tlpkg/tlperl/lib/CPANPLUS/Backend/RV.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend/RV.pm
new file mode 100644
index 00000000000..9edbe0452c9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Backend/RV.pm
@@ -0,0 +1,144 @@
+package CPANPLUS::Backend::RV;
+
+use strict;
+use vars qw[$STRUCT];
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use IPC::Cmd qw[can_run run];
+use Params::Check qw[check];
+
+use base 'Object::Accessor';
+
+local $Params::Check::VERBOSE = 1;
+
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Backend::RV
+
+=head1 SYNOPSIS
+
+ ### create a CPANPLUS::Backend::RV object
+ $backend_rv = CPANPLUS::Backend::RV->new(
+ ok => $boolean,
+ args => $args,
+ rv => $return_value
+ function => $calling_function );
+
+ ### if you have a CPANPLUS::Backend::RV object
+ $passed_args = $backend_rv->args; # args passed to function
+ $ok = $backend_rv->ok; # boolean indication overall
+ # result of the call
+ $function = $backend_rv->fucntion # name of the calling
+ # function
+ $rv = $backend_rv->rv # the actual return value
+ # of the calling function
+
+=head1 DESCRIPTION
+
+This module provides return value objects for multi-module
+calls to CPANPLUS::Backend. In boolean context, it returns the status
+of the overall result (ie, the same as the C<ok> method would).
+
+=head1 METHODS
+
+=head2 new( ok => BOOL, args => DATA, rv => DATA, [function => $method_name] )
+
+Creates a new CPANPLUS::Backend::RV object from the data provided.
+This method should only be called by CPANPLUS::Backend functions.
+The accessors may be used by users inspecting an RV object.
+
+All the argument names can be used as accessors later to retrieve the
+data.
+
+Arguments:
+
+=over 4
+
+=item ok
+
+Boolean indicating overall success
+
+=item args
+
+The arguments provided to the function that returned this rv object.
+Useful to inspect later to see what was actually passed to the function
+in case of an error.
+
+=item rv
+
+An arbitrary data structure that has the detailed return values of each
+of your multi-module calls.
+
+=item function
+
+The name of the function that created this rv object.
+Can be explicitly passed. If not, C<new()> will try to deduce the name
+from C<caller()> information.
+
+=back
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ ok => { required => 1, allow => BOOLEANS },
+ args => { required => 1 },
+ rv => { required => 1 },
+ function => { default => CALLING_FUNCTION->() },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+ my $self = bless {}, $class;
+
+# $self->mk_accessors( qw[ok args function rv] );
+ $self->mk_accessors( keys %$tmpl );
+
+ ### set the values passed in the struct ###
+ while( my($key,$val) = each %$args ) {
+ $self->$key( $val );
+ }
+
+ return $self;
+}
+
+sub _ok { return shift->ok }
+#sub _stringify { Carp::carp( "stringifying!" ); overload::StrVal( shift ) }
+
+### make it easier to check if($rv) { foo() }
+### this allows people to not have to explicitly say
+### if( $rv->ok ) { foo() }
+### XXX add an explicit stringify, so it doesn't fall back to "bool"? :(
+use overload bool => \&_ok,
+# '""' => \&_stringify,
+ fallback => 1;
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Config.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Config.pm
new file mode 100644
index 00000000000..740ef1e637f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Config.pm
@@ -0,0 +1,797 @@
+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];
+
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Config
+
+=head1 SYNOPSIS
+
+ ### conf object via CPANPLUS::Backend;
+ $cb = CPANPLUS::Backend->new;
+ $conf = $cb->configure_object;
+
+ ### or as a standalone object
+ $conf = CPANPLUS::Configure->new;
+
+ ### values in 'conf' section
+ $verbose = $conf->get_conf( 'verbose' );
+ $conf->set_conf( verbose => 1 );
+
+ ### values in 'program' section
+ $editor = $conf->get_program( 'editor' );
+ $conf->set_program( editor => '/bin/vi' );
+
+=head1 DESCRIPTION
+
+This module contains defaults and heuristics for configuration
+information for CPANPLUS. To change any of these values, please
+see the documentation in C<CPANPLUS::Configure>.
+
+Below you'll find a list of configuration types and keys, and
+their meaning.
+
+=head1 CONFIGURATION
+
+=cut
+
+### BAH! you can't have POD interleaved with a hash
+### declaration.. so declare every entry seperatedly :(
+my $Conf = {
+ '_fetch' => {
+ 'blacklist' => [ 'ftp' ],
+ },
+
+ ### _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',
+ 'custom_index' => 'packages.txt',
+ },
+ '_build' => {
+ 'plugins' => 'plugins',
+ 'moddir' => 'build',
+ 'startdir' => '',
+ 'distdir' => 'dist',
+ 'autobundle' => 'autobundle',
+ 'autobundle_prefix' => 'Snapshot',
+ 'autdir' => 'authors',
+ 'install_log_dir' => 'install-logs',
+ 'custom_sources' => 'custom-sources',
+ 'sanity_check' => 1,
+ },
+ '_mirror' => {
+ 'base' => 'authors/id/',
+ 'auth' => 'authors/01mailrc.txt.gz',
+ 'dslip' => 'modules/03modlist.data.gz',
+ 'mod' => 'modules/02packages.details.txt.gz'
+ },
+};
+
+=head2 Section 'conf'
+
+=over 4
+
+=item hosts
+
+An array ref containing hosts entries to be queried for packages.
+
+An example entry would like this:
+
+ { 'scheme' => 'ftp',
+ 'path' => '/pub/CPAN/',
+ 'host' => 'ftp.cpan.org'
+ },
+
+=cut
+
+ ### default host list
+ $Conf->{'conf'}->{'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'
+ }
+ ];
+
+=item allow_build_interactivity
+
+Boolean flag to indicate whether 'perl Makefile.PL' and similar
+are run interactively or not. Defaults to 'true'.
+
+=cut
+
+ $Conf->{'conf'}->{'allow_build_interactivity'} = 1;
+
+=item base
+
+The directory CPANPLUS keeps all its build and state information in.
+Defaults to ~/.cpanplus.
+
+=cut
+
+ $Conf->{'conf'}->{'base'} = File::Spec->catdir(
+ __PACKAGE__->_home_dir, DOT_CPANPLUS );
+
+=item buildflags
+
+Any flags to be passed to 'perl Build.PL'. See C<perldoc Module::Build>
+for details. Defaults to an empty string.
+
+=cut
+
+ $Conf->{'conf'}->{'buildflags'} = '';
+
+=item cpantest
+
+Boolean flag to indicate whether or not to mail test results of module
+installations to C<http://testers.cpan.org>. Defaults to 'false'.
+
+=cut
+
+ $Conf->{'conf'}->{'cpantest'} = 0;
+
+=item cpantest_mx
+
+String holding an explicit mailserver to use when sending out emails
+for C<http://testers.cpan.org>. An empty string will use your system
+settings. Defaults to an empty string.
+
+=cut
+
+ $Conf->{'conf'}->{'cpantest_mx'} = '';
+
+=item debug
+
+Boolean flag to enable or disable extensive debuggging information.
+Defaults to 'false'.
+
+=cut
+
+ $Conf->{'conf'}->{'debug'} = 0;
+
+=item dist_type
+
+Default distribution type to use when building packages. See C<cpan2dist>
+or C<CPANPLUS::Dist> for details. An empty string will not use any
+package building software. Defaults to an empty string.
+
+=cut
+
+ $Conf->{'conf'}->{'dist_type'} = '';
+
+=item email
+
+Email address to use for anonymous ftp access and as C<from> address
+when sending emails. Defaults to an C<example.com> address.
+
+=cut
+
+ $Conf->{'conf'}->{'email'} = DEFAULT_EMAIL;
+
+=item enable_custom_sources
+
+Boolean flag indicating whether custom sources should be enabled or
+not. See the C<CUSTOM MODULE SOURCES> in C<CPANPLUS::Backend> for
+details on how to use them.
+
+Defaults to C<true>
+
+=cut
+
+ ### this addresses #32248 which requests a possibillity to
+ ### turn off custom sources
+ $Conf->{'conf'}->{'enable_custom_sources'} = 1;
+
+=item extractdir
+
+String containing the directory where fetched archives should be
+extracted. An empty string will use a directory under your C<base>
+directory. Defaults to an empty string.
+
+=cut
+
+ $Conf->{'conf'}->{'extractdir'} = '';
+
+=item fetchdir
+
+String containing the directory where fetched archives should be
+stored. An empty string will use a directory under your C<base>
+directory. Defaults to an empty string.
+
+=cut
+
+ $Conf->{'conf'}->{'fetchdir'} = '';
+
+=item flush
+
+Boolean indicating whether build failures, cache dirs etc should
+be flushed after every operation or not. Defaults to 'true'.
+
+=cut
+
+ $Conf->{'conf'}->{'flush'} = 1;
+
+=item force
+
+Boolean indicating whether files should be forcefully overwritten
+if they exist, modules should be installed when they fail tests,
+etc. Defaults to 'false'.
+
+=cut
+
+ $Conf->{'conf'}->{'force'} = 0;
+
+=item lib
+
+An array ref holding directories to be added to C<@INC> when CPANPLUS
+starts up. Defaults to an empty array reference.
+
+=cut
+
+ $Conf->{'conf'}->{'lib'} = [];
+
+=item makeflags
+
+A string holding flags that will be passed to the C<make> program
+when invoked. Defaults to an empty string.
+
+=cut
+
+ $Conf->{'conf'}->{'makeflags'} = '';
+
+=item makemakerflags
+
+A string holding flags that will be passed to C<perl Makefile.PL>
+when invoked. Defaults to an empty string.
+
+=cut
+
+ $Conf->{'conf'}->{'makemakerflags'} = '';
+
+=item md5
+
+A boolean indicating whether or not md5 checks should be done when
+an archive is fetched. Defaults to 'true' if you have C<Digest::MD5>
+installed, 'false' otherwise.
+
+=cut
+
+ $Conf->{'conf'}->{'md5'} = (
+ check_install( module => 'Digest::MD5' ) ? 1 : 0 );
+
+=item no_update
+
+A boolean indicating whether or not C<CPANPLUS>' source files should be
+updated or not. Defaults to 'false'.
+
+=cut
+
+ $Conf->{'conf'}->{'no_update'} = 0;
+
+=item passive
+
+A boolean indicating whether or not to use passive ftp connections.
+Defaults to 'true'.
+
+=cut
+
+ $Conf->{'conf'}->{'passive'} = 1;
+
+=item prefer_bin
+
+A boolean indicating whether or not to prefer command line programs
+over perl modules. Defaults to 'false' unless you do not have
+C<Compress::Zlib> installed (as that would mean we could not extract
+C<.tar.gz> files)
+
+=cut
+ ### 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
+ $Conf->{'conf'}->{'prefer_bin'} =
+ (eval {require Compress::Zlib; 1} ? 0 : 1 );
+
+=item prefer_makefile
+
+A boolean indicating whether or not prefer a C<Makefile.PL> over a
+C<Build.PL> file if both are present. Defaults to 'true', unless
+the perl version is at least 5.10.1 or appropriate versions of L<Module::Build>
+and L<CPANPLUS::Dist::Build> are available.
+
+=cut
+
+ $Conf->{'conf'}->{'prefer_makefile'} =
+ ( $] >= 5.010001 or
+ ( check_install( module => 'Module::Build', version => '0.32' ) and
+ check_install( module => INSTALLER_BUILD, version => '0.24' ) )
+ ? 0 : 1 );
+
+=item prereqs
+
+A digit indicating what to do when a package you are installing has a
+prerequisite. Options are:
+
+ 0 Do not install
+ 1 Install
+ 2 Ask
+ 3 Ignore (dangerous, install will probably fail!)
+
+The default is to ask.
+
+=cut
+
+ $Conf->{'conf'}->{'prereqs'} = PREREQ_ASK;
+
+=item shell
+
+A string holding the shell class you wish to start up when starting
+C<CPANPLUS> in interactive mode.
+
+Defaults to C<CPANPLUS::Shell::Default>, the default CPANPLUS shell.
+
+=cut
+
+ $Conf->{'conf'}->{'shell'} = 'CPANPLUS::Shell::Default';
+
+=item show_startup_tip
+
+A boolean indicating whether or not to show start up tips in the
+interactive shell. Defaults to 'true'.
+
+=cut
+
+ $Conf->{'conf'}->{'show_startup_tip'} = 1;
+
+=item signature
+
+A boolean indicating whether or not check signatures if packages are
+signed. Defaults to 'true' if you have C<gpg> or C<Crypt::OpenPGP>
+installed, 'false' otherwise.
+
+=cut
+
+ $Conf->{'conf'}->{'signature'} = do {
+ check_install( module => 'Module::Signature', version => '0.06' )
+ and ( can_run('gpg') ||
+ check_install(module => 'Crypt::OpenPGP')
+ );
+ } ? 1 : 0;
+
+=item skiptest
+
+A boolean indicating whether or not to skip tests when installing modules.
+Defaults to 'false'.
+
+=cut
+
+ $Conf->{'conf'}->{'skiptest'} = 0;
+
+=item storable
+
+A boolean indicating whether or not to use C<Storable> to write compiled
+source file information to disk. This makes for faster startup and look
+up times, but takes extra diskspace. Defaults to 'true' if you have
+C<Storable> installed and 'false' if you don't.
+
+=cut
+
+ $Conf->{'conf'}->{'storable'} =
+ ( check_install( module => 'Storable' ) ? 1 : 0 );
+
+=item timeout
+
+Digit indicating the time before a fetch request times out (in seconds).
+Defaults to 300.
+
+=cut
+
+ $Conf->{'conf'}->{'timeout'} = 300;
+
+=item verbose
+
+A boolean indicating whether or not C<CPANPLUS> runs in verbose mode.
+Defaults to 'true' if you have the environment variable
+C<PERL5_CPANPLUS_VERBOSE> set to true, 'false' otherwise.
+
+It is recommended you run with verbose enabled, but it is disabled
+for historical reasons.
+
+=cut
+
+ $Conf->{'conf'}->{'verbose'} = $ENV{PERL5_CPANPLUS_VERBOSE} || 0;
+
+=item write_install_log
+
+A boolean indicating whether or not to write install logs after installing
+a module using the interactive shell. Defaults to 'true'.
+
+
+=cut
+
+ $Conf->{'conf'}->{'write_install_logs'} = 1;
+
+=item source_engine
+
+Class to use as the source engine, which is generally a subclass of
+C<CPANPLUS::Internals::Source>. Default to C<CPANPLUS::Internals::Source::Memory>.
+
+=cut
+
+ $Conf->{'conf'}->{'source_engine'} = DEFAULT_SOURCE_ENGINE;
+
+=item cpantest_reporter_args
+
+A hashref of key => value pairs that are passed to the constructor
+of C<Test::Reporter>. If you'd want to enable TLS for example, you'd
+set it to:
+
+ { transport => 'Net::SMTP::TLS',
+ transport_args => [ User => 'Joe', Password => '123' ],
+ }
+
+=cut
+
+ $Conf->{'conf'}->{'cpantest_reporter_args'} = {};
+
+=back
+
+=head2 Section 'program'
+
+=cut
+
+ ### Paths get stripped of whitespace on win32 in the constructor
+ ### sudo gets emptied if there's no need for it in the constructor
+
+=over 4
+
+=item editor
+
+A string holding the path to your editor of choice. Defaults to your
+$ENV{EDITOR}, $ENV{VISUAL}, 'vi' or 'pico' programs, in that order.
+
+=cut
+
+ $Conf->{'program'}->{'editor'} = do {
+ $ENV{'EDITOR'} || $ENV{'VISUAL'} ||
+ can_run('vi') || can_run('pico')
+ };
+
+=item make
+
+A string holding the path to your C<make> binary. Looks for the C<make>
+program used to build perl or failing that, a C<make> in your path.
+
+=cut
+
+ $Conf->{'program'}->{'make'} =
+ can_run($Config{'make'}) || can_run('make');
+
+=item pager
+
+A string holding the path to your pager of choice. Defaults to your
+$ENV{PAGER}, 'less' or 'more' programs, in that order.
+
+=cut
+
+ $Conf->{'program'}->{'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' => '',
+
+=item shell
+
+A string holding the path to your login shell of choice. Defaults to your
+$ENV{SHELL} setting, or $ENV{COMSPEC} on Windows.
+
+=cut
+
+ $Conf->{'program'}->{'shell'} = $^O eq 'MSWin32'
+ ? $ENV{COMSPEC}
+ : $ENV{SHELL};
+
+=item sudo
+
+A string holding the path to your C<sudo> binary if your install path
+requires super user permissions. Looks for C<sudo> in your path, or
+remains empty if you do not require super user permissions to install.
+
+=cut
+
+ $Conf->{'program'}->{'sudo'} = do {
+ ### let's assume you dont need sudo,
+ ### unless one of the below criteria tells us otherwise
+ my $sudo = undef;
+
+ ### you're a normal user, you might need sudo
+ if( $> ) {
+
+ ### check for all install dirs!
+ ### you have write permissions to the installdir,
+ ### you don't need sudo
+ if( -w $Config{'installsitelib'} && -w $Config{'installsitebin'} ) {
+
+ ### installsiteman3dir is a 5.8'ism.. don't check
+ ### it on 5.6.x...
+ if( defined $Config{'installsiteman3dir'} ) {
+ $sudo = -w $Config{'installsiteman3dir'}
+ ? undef
+ : can_run('sudo');
+ } else {
+ $sudo = undef;
+ }
+
+ ### you have PERL_MM_OPT set to some alternate
+ ### install place. You probably have write permissions
+ ### to that
+ } elsif ( $ENV{'PERL_MM_OPT'} and
+ $ENV{'PERL_MM_OPT'} =~ /INSTALL|LIB|PREFIX/
+ ) {
+ $sudo = undef;
+
+ ### you probably don't have write permissions
+ } else {
+ $sudo = can_run('sudo');
+ }
+ }
+
+ ### and return the value
+ $sudo;
+ };
+
+=item perlwrapper
+
+A string holding the path to the C<cpanp-run-perl> utility bundled
+with CPANPLUS, which is used to enable autoflushing in spawned processes.
+
+=cut
+
+ ### perlwrapper that allows us to turn on autoflushing
+ $Conf->{'program'}->{'perlwrapper'} = sub {
+ my $name = 'cpanp-run-perl';
+
+ my @bins = do{
+ require Config;
+ my $ver = $Config::Config{version};
+
+ ### if we are running with 'versiononly' enabled,
+ ### all binaries will have the perlversion appended
+ ### ie, cpanp will become cpanp5.9.5
+ ### so prefer the versioned binary in that case
+ $Config::Config{versiononly}
+ ? ($name.$ver, $name)
+ : ($name, $name.$ver);
+ };
+
+ ### patch from Steve Hay Fri 29 Jun 2007 14:26:02 GMT+02:00
+ ### Msg-Id: <4684FA5A.7030506@uk.radan.com>
+ ### look for files with a ".bat" extension as well on Win32
+ @bins = map { $_, "$_.bat" } @bins if $^O eq 'MSWin32';
+
+ my $path;
+ BIN: for my $bin (@bins) {
+
+ ### parallel to your cpanp/cpanp-boxed
+ my $maybe = File::Spec->rel2abs(
+ File::Spec->catfile( dirname($0), $bin )
+ );
+ $path = $maybe and last BIN if -f $maybe;
+
+ ### parallel to your CPANPLUS.pm:
+ ### $INC{cpanplus}/../bin/cpanp-run-perl
+ $maybe = File::Spec->rel2abs(
+ File::Spec->catfile(
+ dirname($INC{'CPANPLUS.pm'}),
+ '..', # lib dir
+ 'bin', # bin dir
+ $bin, # script
+ )
+ );
+ $path = $maybe and last BIN if -f $maybe;
+
+ ### 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
+ $maybe = File::Spec->rel2abs(
+ File::Spec->catfile(
+ dirname( $INC{'CPANPLUS.pm'} ),
+ '..', '..', '..', '..', # 4x updir
+ 'bin', # bin dir
+ $bin, # script
+ )
+ );
+ $path = $maybe and last BIN if -f $maybe;
+
+ ### 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...
+ ### prefer anything that's found in the path paralel to your $^X
+ for my $dir (File::Spec->rel2abs( dirname($^X) ),
+ split(/\Q$Config::Config{path_sep}\E/, $ENV{PATH}),
+ File::Spec->curdir,
+ ) {
+
+ ### On VMS the path could be in UNIX format, and we
+ ### currently need it to be in VMS format
+ $dir = VMS::Filespec::vmspath($dir) if ON_VMS;
+
+ $maybe = File::Spec->catfile( $dir, $bin );
+ $path = $maybe and last BIN if -f $maybe;
+ }
+ }
+
+ ### we should have a $path by now ideally, if so return it
+ return $path if defined $path;
+
+ ### if not, warn about it and give sensible default.
+ ### XXX try to be a no-op instead then..
+ ### cross your fingers...
+ ### pass '-P' to perl: "run program through C
+ ### preprocessor before compilation"
+ ### XXX using -P actually changes the way some Makefile.PLs
+ ### are executed, so don't do that... --kane
+ error(loc(
+ "Could not find the '%1' binary in your path".
+ "--this may be a problem.\n".
+ "Please locate this program and set ".
+ "your '%2' config entry to its path.\n".
+ "From the default shell, you can do this by typing:\n\n".
+ " %3\n".
+ " %4\n",
+ $name, 'perlwrapper',
+ 's program perlwrapper FULL_PATH_TO_CPANP_RUN_PERL',
+ 's save'
+ ));
+ return '';
+ }->();
+
+=back
+
+=cut
+
+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 ) {
+ my $path = $self->program->$pgm;
+
+ ### paths with whitespace needs to be shortened
+ ### for shell outs.
+ if ($path and $path =~ /\s+/) {
+ my($prog, $args);
+
+ ### patch from Steve Hay, 13nd of June 2007
+ ### msg-id: <467012A4.6060705@uk.radan.com>
+ ### windows directories are not allowed to end with
+ ### a space, so any occurrence of '\w\s+/\w+' means
+ ### we're dealing with arguments, not directory
+ ### names.
+ if ($path =~ /^(.*?)(\s+\/.*$)/) {
+ ($prog, $args) = ($1, $2);
+
+ ### otherwise, there are no arguments
+ } else {
+ ($prog, $args) = ($path, '');
+ }
+
+ $prog = Win32::GetShortPathName( $prog );
+ $self->program->$pgm( $prog . $args );
+ }
+ }
+ }
+
+ return 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>, L<CPANPLUS::Configure>
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm
new file mode 100644
index 00000000000..baac91dc886
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure.pm
@@ -0,0 +1,630 @@
+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 _lib _perl5lib]) {
+ 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.
+
+=item load_configs
+
+Controls whether 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;
+
+ ### after processing the config files, check what
+ ### @INC and PERL5LIB are set to.
+ $self->_lib( \@INC );
+ $self->_perl5lib( $ENV{'PERL5LIB'} );
+
+ 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
+ );
+
+ ### if the base dir is changed, we have to rescan it
+ ### for any CPANPLUS::Config::* files as well, so keep
+ ### track of it
+ my $cur_base = $self->get_conf('base');
+
+ ### 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 = ( LIB_DIR->($cur_base), @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 => [ LIB_DIR->($cur_base) ],
+ 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);
+
+ if( eval { load $plugin; 1 } ) {
+ msg(loc(" Loaded '%1' (%2)",
+ $plugin, Module::Loaded::is_loaded( $plugin ) ), 0);
+ } else {
+ error(loc(" Error loading '%1': %2", $plugin, $@));
+ }
+ }
+
+ if( $@ ) {
+ error(loc("Could not load '%1': %2", $plugin, $@));
+ next;
+ }
+
+ my $sub = $plugin->can('setup');
+ $sub->( $self ) if $sub;
+ }
+ }
+
+ ### did one of the plugins change the base dir? then we should
+ ### scan the dirs again
+ if( $cur_base ne $self->get_conf('base') ) {
+ msg(loc("Base dir changed from '%1' to '%2', rescanning",
+ $cur_base, $self->get_conf('base')), 0);
+ $self->init( @_, rescan => 1 );
+ }
+
+ ### clean up the paths once more, just in case
+ $obj->_clean_up_paths;
+
+ ### XXX in case the 'lib' param got changed, we need to
+ ### add that now, or it's not propagating ;(
+ { my $lib = $self->get_conf('lib');
+ my %inc = map { $_ => $_ } @INC;
+ for my $l ( @$lib ) {
+ push @INC, $l unless $inc{$l};
+ }
+ $self->_lib( \@INC );
+ }
+
+ 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.
+
+See the C<CPANPLUS::Config> documentation for what items can be
+set and retrieved.
+
+=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_fetch
+
+Special settings pertaining to the fetching of files.
+
+=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>, L<CPANPLUS::Config>
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm
new file mode 100644
index 00000000000..3bcf8f45090
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm
@@ -0,0 +1,1653 @@
+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
+
+The file will not be overwritten until you explicitly save it.
+
+ ], $file );
+
+ redo ASK_CONFIG_TYPE
+ unless $term->ask_yn(
+ prompt => loc( "Do you wish to use this file?"),
+ 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 "\n", loc("Where can I find your '%1' utility? ".
+ "(Enter a single space to disable)", $prog ), "\n";
+
+ 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 sqlite ? ##
+ ###################
+
+ print loc("
+
+To limit the amount of RAM used by CPANPLUS, you can use the SQLite
+source backend instead. Note that it is currently still experimental.
+Would you like to do this?
+
+");
+ my $type = 'source_engine';
+ my $class = 'CPANPLUS::Internals::Source::SQLite';
+ my $yn = $term->ask_yn(
+ prompt => loc("Use SQLite?"),
+ default => $conf->get_conf( $type ) eq $class ? 1 : 0,
+ );
+ print "\n";
+ print $yn
+ ? loc("I will use SQLite")
+ : loc("I will not use SQLite");
+
+ $conf->set_conf( $type => $class );
+ }
+
+ {
+ ###################
+ ## 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/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm
new file mode 100644
index 00000000000..551b8ec405f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist.pm
@@ -0,0 +1,688 @@
+package CPANPLUS::Dist;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use Cwd ();
+use Object::Accessor;
+use Parse::CPAN::Meta;
+
+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';
+
+use base 'Object::Accessor';
+
+local $Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Dist
+
+=head1 SYNOPSIS
+
+ my $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new(
+ module => $modobj,
+ );
+
+=head1 DESCRIPTION
+
+C<CPANPLUS::Dist> is a base class for C<CPANPLUS::Dist::MM>
+and C<CPANPLUS::Dist::Build>. Developers of other C<CPANPLUS::Dist::*>
+plugins should look at C<CPANPLUS::Dist::Base>.
+
+=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
+
+=back
+
+=head2 $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( module => MODOBJ );
+
+Create a new C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object based on the
+provided C<MODOBJ>.
+
+*** DEPRECATED ***
+The optional argument C<format> is used to indicate what type of dist
+you would like to create (like C<CPANPLUS::Dist::MM> or
+C<CPANPLUS::Dist::Build> and so on ).
+
+C<< CPANPLUS::Dist->new >> is exlusively meant as a method to be
+inherited by C<CPANPLUS::Dist::MM|Build>.
+
+Returns a C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object on success
+and false on failure.
+
+=cut
+
+sub new {
+ my $self = shift;
+ my $class = ref $self || $self;
+ my %hash = @_;
+
+ ### first verify we got a module object ###
+ my( $mod, $format );
+ my $tmpl = {
+ module => { required => 1, allow => IS_MODOBJ, store => \$mod },
+ ### for backwards compatibility
+ format => { default => $class, store => \$format,
+ allow => [ __PACKAGE__->dist_types ],
+ },
+ };
+ check( $tmpl, \%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;
+ }
+
+ ### get an empty o::a object for this class
+ my $obj = $format->SUPER::new;
+
+ $obj->mk_accessors( qw[parent status] );
+
+ ### set the parent
+ $obj->parent( $mod );
+
+ ### 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] );
+ }
+
+ ### get the conf object ###
+ my $conf = $mod->parent->configure_object();
+
+ ### 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;
+ }
+
+ ### 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, @_ };
+ sub _reset_dist_ignore { @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+$';
+ my %except = map { $_ => 1 }
+ INSTALLER_SAMPLE,
+ INSTALLER_BASE;
+
+ Module::Pluggable->import(
+ sub_name => '_dist_types',
+ search_path => __PACKAGE__,
+ only => qr/$only_re/,
+ require => 1,
+ except => [ keys %except ]
+ );
+ my %ignore = map { $_ => $_ } @Ignore;
+
+ push @Dists, grep { not $ignore{$_} and not $except{$_} }
+ __PACKAGE__->_dist_types;
+ }
+
+ return @Dists;
+ }
+
+=head2 $bool = CPANPLUS::Dist->rescan_dist_types;
+
+Rescans C<@INC> for available dist types. Useful if you've installed new
+C<CPANPLUS::Dist::*> classes and want to make them available to the
+current process.
+
+=cut
+
+ sub rescan_dist_types {
+ my $dist = shift;
+ $Loaded = 0; # reset the flag;
+ return $dist->dist_types;
+ }
+}
+
+=head2 $bool = CPANPLUS::Dist->has_dist_type( $type )
+
+Returns true if distribution type C<$type> is loaded/supported.
+
+=cut
+
+sub has_dist_type {
+ my $dist = shift;
+ my $type = shift or return;
+
+ return scalar grep { $_ eq $type } CPANPLUS::Dist->dist_types;
+}
+
+=head2 $bool = $dist->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 $configure_requires = $dist->find_configure_requires( [file => /path/to/META.yml] )
+
+Reads the configure_requires for this distribution from the META.yml
+file in the root directory and returns a hashref with module names
+and versions required.
+
+=cut
+
+sub find_configure_requires {
+ my $self = shift;
+ my $mod = $self->parent;
+ my $meth = 'configure_requires';
+
+ ### the prereqs as we have them now
+ my @args = (
+ defaults => $mod->status->$meth || {},
+ keys => [ $meth ],
+ );
+
+ ### the default file to use, which may be overriden
+ push @args, ( file => META_YML->( $mod->status->extract ) )
+ if defined $mod->status->extract;
+
+ my $href = $self->_prereqs_from_meta_file( @args, @_ );
+
+ ### and store it in the module
+ $mod->status->$meth( $href );
+
+ return { %$href };
+}
+
+sub find_mymeta_requires {
+ my $self = shift;
+ my $mod = $self->parent;
+ my $meth = 'prereqs';
+
+ ### the prereqs as we have them now
+ my @args = (
+ defaults => $mod->status->$meth || {},
+ keys => [qw|requires build_requires|],
+ );
+
+ ### the default file to use, which may be overriden
+ push @args, ( file => MYMETA_YML->( $mod->status->extract ) )
+ if defined $mod->status->extract;
+
+ my $href = $self->_prereqs_from_meta_file( @args, @_ );
+
+ ### and store it in the module
+ $mod->status->$meth( $href );
+
+ return { %$href };
+}
+
+sub _prereqs_from_meta_file {
+ my $self = shift;
+ my $mod = $self->parent;
+ my %hash = @_;
+
+ my( $meta, $defaults, $keys );
+ my $tmpl = { ### check if we have an extract path. if not, we
+ ### get 'undef value' warnings from file::spec
+ file => { default => do { defined $mod->status->extract
+ ? META_YML->( $mod->status->extract )
+ : '' },
+ store => \$meta,
+ },
+ defaults => { required => 1, default => {}, strict_type => 1,
+ store => \$defaults },
+ keys => { required => 1, default => [], strict_type => 1,
+ store => \$keys },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### if there's a meta file, we read it;
+ if( -e $meta ) {
+
+ ### Parse::CPAN::Meta uses exceptions for errors
+ ### hash returned in list context!!!
+ my ($doc) = eval { Parse::CPAN::Meta::LoadFile( $meta ) };
+
+ unless( $doc ) {
+ error(loc( "Could not read %1: '%2'", $meta, $@ ));
+ return $defaults;
+ }
+
+ ### read the keys now, make sure not to throw
+ ### away anything that was already added
+ for my $key ( @$keys ) {
+ $defaults = {
+ %$defaults,
+ %{ $doc->{$key} },
+ } if $doc->{ $key };
+ }
+ }
+
+ ### and return a copy
+ return \%{ $defaults };
+}
+
+=head2 $bool = $dist->_resolve_prereqs( ... )
+
+Makes sure prerequisites are resolved
+
+ format The dist class to use to make the prereqs
+ (ie. CPANPLUS::Dist::MM)
+
+ prereqs Hash of the prerequisite modules and their versions
+
+ target What to do with the prereqs.
+ create => Just build them
+ install => Install them
+ ignore => Ignore them
+
+ prereq_build If true, always build the prereqs even if already
+ resolved
+
+ verbose Be verbose
+
+ force Force the prereq to be built, even if already resolved
+
+=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;
+
+ ### Make sure we wound up where we started.
+ my $original_wd = Cwd::cwd;
+
+ ### 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};
+
+ ### 'perl' is a special case, there's no mod object for it
+ if( $mod eq PERL_CORE ) {
+
+ ### run a CLI invocation to see if the perl you specified is
+ ### uptodate
+ my $ok = run( command => "$^X -M$version -e1", verbose => 0 );
+
+ unless( $ok ) {
+ error(loc( "Module '%1' needs perl version '%2', but you ".
+ "only have version '%3' -- can not proceed",
+ $self->module, $version,
+ $cb->_perl_version( perl => $^X ) ) );
+ return;
+ }
+
+ next;
+ }
+
+ 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 ) {
+ # Check if it is a core module
+ my $sub = CPANPLUS::Module->can(
+ 'module_is_supplied_with_perl_core' );
+ my $core = $sub->( $mod );
+ unless ( $core ) {
+ error( loc( "No such module '%1' found on CPAN", $mod ) );
+ next;
+ }
+ if ( $cb->_vcmp( $version, $core ) > 0 ) {
+ error(loc( "Version of core module '%1' ('%2') is too low for ".
+ "'%3' (needs '%4') -- carrying on but this may be a problem",
+ $mod, $core,
+ $self->module, $version ));
+ }
+ 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;
+
+ ### chdir back to where we started
+ chdir $original_wd;
+
+ 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/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Autobundle.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Autobundle.pm
new file mode 100644
index 00000000000..16638b258f8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Autobundle.pm
@@ -0,0 +1,117 @@
+package CPANPLUS::Dist::Autobundle;
+
+use strict;
+use warnings;
+use CPANPLUS::Error qw[error msg];
+use Params::Check qw[check];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+use base qw[CPANPLUS::Dist::Base];
+
+=head1 NAME
+
+CPANPLUS::Dist::Autobundle
+
+=head1 SYNOPSIS
+
+ $modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' );
+ $modobj->install;
+
+=head1 DESCRIPTION
+
+C<CPANPLUS::Dist::Autobundle> is a distribution class for installing installation
+snapshots as created by C<CPANPLUS>' C<autobundle> command.
+
+All modules as mentioned in the snapshot will be installed on your system.
+
+=cut
+
+sub init {
+ my $dist = shift;
+ my $status = $dist->status;
+
+ $status->mk_accessors(
+ qw[prepared created installed _prepare_args _create_args _install_args]
+ );
+
+ return 1;
+}
+
+sub prepare {
+ my $dist = shift;
+ my %args = @_;
+
+ ### store the arguments, so ->install can use them in recursive loops ###
+ $dist->status->_prepare_args( \%args );
+
+ return $dist->status->prepared( 1 );
+}
+
+sub create {
+ 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( $force, $verbose, $prereq_target, $prereq_format, $prereq_build);
+
+ my $args = do {
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+ my $tmpl = {
+ force => { default => $conf->get_conf('force'),
+ store => \$force },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ 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 },
+ };
+
+ 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( \%hash );
+
+ msg(loc("Resolving prerequisites mentioned in the bundle"), $verbose);
+
+ ### 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,
+ );
+
+ ### if all went well, mark it & return
+ return $dist->status->created( $ok ? 1 : 0);
+}
+
+sub install {
+ my $dist = shift;
+ my %args = @_;
+
+ ### store the arguments, so ->install can use them in recursive loops ###
+ $dist->status->_install_args( \%args );
+
+ return $dist->status->installed( 1 );
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Base.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Base.pm
new file mode 100644
index 00000000000..c7108ed1392
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Base.pm
@@ -0,0 +1,261 @@
+package CPANPLUS::Dist::Base;
+
+use strict;
+
+use base qw[CPANPLUS::Dist];
+use vars qw[$VERSION];
+$VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION;
+
+
+=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 @subs = $Class->methods
+
+Returns a list of methods that this class implements that you can
+override.
+
+=cut
+
+sub methods {
+ return qw[format_available init prepare create install uninstall]
+}
+
+=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 its 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;
+ my $format = ref $dist;
+
+ ### 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(prereq_format => $format, @_) );
+}
+
+=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/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build.pm
new file mode 100644
index 00000000000..0f27639cda5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build.pm
@@ -0,0 +1,836 @@
+package CPANPLUS::Dist::Build;
+
+use strict;
+use warnings;
+use vars qw[@ISA $STATUS $VERSION];
+@ISA = qw[CPANPLUS::Dist];
+
+use CPANPLUS::Internals::Constants;
+
+### these constants were exported by CPANPLUS::Internals::Constants
+### in previous versions.. they do the same though. If we want to have
+### a normal 'use' here, up the dependency to CPANPLUS 0.056 or higher
+BEGIN {
+ require CPANPLUS::Dist::Build::Constants;
+ CPANPLUS::Dist::Build::Constants->import()
+ if not __PACKAGE__->can('BUILD') && __PACKAGE__->can('BUILD_DIR');
+}
+
+use CPANPLUS::Error;
+
+use Config;
+use FileHandle;
+use Cwd;
+use version;
+
+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;
+
+$VERSION = '0.46';
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Dist::Build - CPANPLUS plugin to install packages that use Build.PL
+
+=head1 SYNOPSIS
+
+ my $build = CPANPLUS::Dist->new(
+ format => 'CPANPLUS::Dist::Build',
+ module => $modobj,
+ );
+
+ $build->prepare; # runs Build.PL
+ $build->create; # runs build && build test
+ $build->install; # runs build install
+
+
+=head1 DESCRIPTION
+
+C<CPANPLUS::Dist::Build> is a distribution class for C<Module::Build>
+related modules.
+Using this package, you can create, install and uninstall perl
+modules. It inherits from C<CPANPLUS::Dist>.
+
+Normal users won't have to worry about the interface to this module,
+as it functions transparently as a plug-in to C<CPANPLUS> and will
+just C<Do The Right Thing> when it's loaded.
+
+=head1 ACCESSORS
+
+=over 4
+
+=item C<parent()>
+
+Returns the C<CPANPLUS::Module> object that parented this object.
+
+=item C<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:
+ $build->status->ACCESSOR
+
+=over 4
+
+=item C<build_pl ()>
+
+Location of the Build file.
+Set to 0 explicitly if something went wrong.
+
+=item C<build ()>
+
+BOOL indicating if the C<Build> command was successful.
+
+=item C<test ()>
+
+BOOL indicating if the C<Build test> command was successful.
+
+=item C<prepared ()>
+
+BOOL indicating if the C<prepare> call exited succesfully
+This gets set after C<perl Build.PL>
+
+=item C<distdir ()>
+
+Full path to the directory in which the C<prepare> call took place,
+set after a call to C<prepare>.
+
+=item C<created ()>
+
+BOOL indicating if the C<create> call exited succesfully. This gets
+set after C<Build> and C<Build test>.
+
+=item C<installed ()>
+
+BOOL indicating if the module was installed. This gets set after
+C<Build install> exits successfully.
+
+=item uninstalled ()
+
+BOOL indicating if the module was uninstalled properly.
+
+=item C<_create_args ()>
+
+Storage of the arguments passed to C<create> for this object. Used
+for recursive calls when satisfying prerequisites.
+
+=item C<_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 = CPANPLUS::Dist::Build->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 $mod = "Module::Build";
+ unless( can_load( modules => { $mod => '0.2611' } ) ) {
+ error( loc( "You do not have '%1' -- '%2' not available",
+ $mod, __PACKAGE__ ) );
+ return;
+ }
+
+ return 1;
+}
+
+
+=head2 $bool = $dist->init();
+
+Sets up the C<CPANPLUS::Dist::Build> 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[build_pl build test created installed uninstalled
+ _create_args _install_args _prepare_args
+ _mb_object _buildflags
+ ]);
+
+ ### just in case 'format_available' didn't get called
+ require Module::Build;
+
+ return 1;
+}
+
+=pod
+
+=head2 $bool = $dist->prepare([perl => '/path/to/perl', buildflags => 'EXTRA=FLAGS', force => BOOL, verbose => BOOL])
+
+C<prepare> prepares a distribution, running C<Build.PL>
+and establishing any prerequisites this
+distribution has.
+
+The variable C<PERL5_CPANPLUS_IS_EXECUTING> will be set to the full path
+of the C<Build.PL> that is being executed. This enables any code inside
+the C<Build.PL> to know that it is being installed via CPANPLUS.
+
+After a succcesfull C<prepare> you may call C<create> to create the
+distribution, followed by C<install> to actually install it.
+
+Returns true on success and false on failure.
+
+=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 from another installer
+ $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, $buildflags, $perl, $prereq_target, $prereq_format,
+ $prereq_build );
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+ my $tmpl = {
+ force => { default => $conf->get_conf('force'),
+ store => \$force },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ perl => { default => $^X, store => \$perl },
+ buildflags => { default => $conf->get_conf('buildflags'),
+ store => \$buildflags },
+ prereq_target => { default => '', store => \$prereq_target },
+ prereq_format => { default => '',
+ store => \$prereq_format },
+ prereq_build => { default => 0, store => \$prereq_build },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ return 1 if $dist->status->prepared && !$force;
+
+ $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;
+ }
+
+ ### by now we've loaded module::build, and we're using the API, so
+ ### it's safe to remove CPANPLUS::inc from our inc path, especially
+ ### because it can trip up tests run under taint (just like EU::MM).
+ ### 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 we've removed the ENV settings from cp::inc, so only need
+ ### to reset the @INC
+ #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt;
+ #local $ENV{PERL5LIB} = CPANPLUS::inc->original_perl5lib;
+ #local @INC = CPANPLUS::inc->original_inc;
+
+ ### this will generate warnings under anything lower than M::B 0.2606
+ my @buildflags = $dist->_buildflags_as_list( $buildflags );
+ $dist->status->_buildflags( $buildflags );
+
+ my $fail;
+ RUN: {
+ # 0.85_01
+ ### we resolve 'configure requires' here, so we can run the 'perl
+ ### Makefile.PL' command
+ ### XXX for tests: mock f_c_r to something that *can* resolve and
+ ### something that *doesnt* resolve. Check the error log for ok
+ ### on this step or failure
+ ### XXX make a seperate tarball to test for this scenario: simply
+ ### containing a makefile.pl/build.pl for test purposes?
+ my $safe_ver = version->new('0.85_01');
+ if ( version->new($CPANPLUS::Internals::VERSION) >= $safe_ver )
+ { my $configure_requires = $dist->find_configure_requires;
+ my $ok = $dist->_resolve_prereqs(
+ format => $prereq_format,
+ verbose => $verbose,
+ prereqs => $configure_requires,
+ target => $prereq_target,
+ force => $force,
+ prereq_build => $prereq_build,
+ );
+
+ unless( $ok ) {
+
+ #### use $dist->flush to reset the cache ###
+ error( loc( "Unable to satisfy '%1' for '%2' " .
+ "-- aborting install",
+ 'configure_requires', $self->module ) );
+ $dist->status->prepared(0);
+ $fail++;
+ last RUN;
+ }
+ ### end of prereq resolving ###
+ }
+
+ # Wrap the exception that may be thrown here (should likely be
+ # done at a much higher level).
+ my $prep_output;
+
+ my $env = ENV_CPANPLUS_IS_EXECUTING;
+ local $ENV{$env} = BUILD_PL->( $dir );
+ my $run_perl = $conf->get_program('perlwrapper');
+ my $cmd = [$perl, $run_perl, BUILD_PL->($dir), @buildflags];
+
+ unless ( scalar run( command => $cmd,
+ buffer => \$prep_output,
+ verbose => $verbose )
+ ) {
+ error( loc( "Build.PL failed: %1", $prep_output ) );
+ $fail++; last RUN;
+ }
+
+ msg( $prep_output, 0 );
+
+ my $prereqs = $self->status->prereqs;
+
+ $prereqs ||= $dist->_find_prereqs( verbose => $verbose,
+ dir => $dir,
+ perl => $perl,
+ buildflags => $buildflags );
+
+ }
+
+ ### send out test report? ###
+ if( $fail and $conf->get_conf('cpantest') ) {
+ $cb->_send_report(
+ module => $self,
+ failed => $fail,
+ buffer => CPANPLUS::Error->stack_as_string,
+ verbose => $verbose,
+ force => $force,
+ ) or error(loc("Failed to send test report for '%1'",
+ $self->module ) );
+ }
+
+ 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 );
+}
+
+sub _find_prereqs {
+ my $dist = shift;
+ my $self = $dist->parent;
+ my $cb = $self->parent;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my ($verbose, $dir, $buildflags, $perl);
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+ dir => { default => $self->status->extract, store => \$dir },
+ perl => { default => $^X, store => \$perl },
+ buildflags => { default => $conf->get_conf('buildflags'),
+ store => \$buildflags },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ my $prereqs = {};
+
+ $prereqs = $dist->find_mymeta_requires()
+ if $dist->can('find_mymeta_requires');
+
+ if ( keys %$prereqs ) {
+ # Ugly hack
+ }
+ else {
+ my $safe_ver = version->new('0.31_03');
+ my $content;
+ PREREQS: {
+ if ( version->new( $Module::Build::VERSION ) >= $safe_ver and IPC::Cmd->can_capture_buffer ) {
+ my @buildflags = $dist->_buildflags_as_list( $buildflags );
+
+ # Use the new Build action 'prereq_data'
+ my $run_perl = $conf->get_program('perlwrapper');
+
+ unless ( scalar run( command => [$perl, $run_perl, BUILD->($dir), 'prereq_data', @buildflags],
+ buffer => \$content,
+ verbose => 0 )
+ ) {
+ error( loc( "Build 'prereq_data' failed: %1 %2", $!, $content ) );
+ #return;
+ }
+ else {
+ last PREREQS;
+ }
+
+ }
+
+ my $file = File::Spec->catfile( $dir, '_build', 'prereqs' );
+ return unless -f $file;
+
+ my $fh = FileHandle->new();
+
+ unless( $fh->open( $file ) ) {
+ error( loc( "Cannot open '%1': %2", $file, $! ) );
+ return;
+ }
+
+ $content = do { local $/; <$fh> };
+
+ }
+
+ return unless $content;
+ my $bphash = eval $content;
+ return unless $bphash and ref $bphash eq 'HASH';
+ foreach my $type ('requires', 'build_requires') {
+ next unless $bphash->{$type} and ref $bphash->{$type} eq 'HASH';
+ $prereqs->{$_} = $bphash->{$type}->{$_} for keys %{ $bphash->{$type} };
+ }
+ }
+ # Temporary fix
+ delete $prereqs->{'perl'};
+
+ ### allows for a user defined callback to filter the prerequisite
+ ### list as they see fit, to remove (or add) any prereqs they see
+ ### fit. The default installed callback will return the hashref in
+ ### an unmodified form
+ ### this callback got added after cpanplus 0.0562, so use a 'can'
+ ### to find out if it's supported. For older versions, we'll just
+ ### return the hashref as is ourselves.
+ my $href = $cb->_callbacks->can('filter_prereqs')
+ ? $cb->_callbacks->filter_prereqs->( $cb, $prereqs )
+ : $prereqs;
+
+ $self->status->prereqs( $href );
+
+ ### make sure it's not the same ref
+ return { %$href };
+}
+
+=pod
+
+=head2 $dist->create([perl => '/path/to/perl', buildflags => 'EXTRA=FLAGS', prereq_target => TARGET, force => BOOL, verbose => BOOL, skiptest => BOOL])
+
+C<create> preps a distribution for installation. This means it will
+run C<Build> and C<Build test>.
+This will also satisfy any prerequisites the module may have.
+
+If you set C<skiptest> to true, it will skip the C<Build test> stage.
+If you set C<force> to true, it will go over all the stages of the
+C<Build> process again, ignoring any previously cached results. It
+will also ignore a bad return value from C<Build 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 from another installer
+ $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, $buildflags, $skiptest, $prereq_target,
+ $perl, $prereq_format, $prereq_build);
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+ my $tmpl = {
+ force => { default => $conf->get_conf('force'),
+ store => \$force },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ perl => { default => $^X, store => \$perl },
+ buildflags => { default => $conf->get_conf('buildflags'),
+ store => \$buildflags },
+ skiptest => { default => $conf->get_conf('skiptest'),
+ store => \$skiptest },
+ prereq_target => { default => '', store => \$prereq_target },
+ ### don't set the default format to 'build' -- that is 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;
+ }
+
+ # restore the state as we have created this already.
+ if ( $dist->status->created && !$force ) {
+ ### add this directory to your lib ###
+ $self->add_to_includepath();
+ return 1;
+ }
+
+ $dist->status->_create_args( $args );
+
+ ### is this dist prepared?
+ 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;
+ }
+
+ ### by now we've loaded module::build, and we're using the API, so
+ ### it's safe to remove CPANPLUS::inc from our inc path, especially
+ ### because it can trip up tests run under taint (just like EU::MM).
+ ### 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 we've removed the ENV settings from cp::inc, so only need
+ ### to reset the @INC
+ #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt;
+ #local $ENV{PERL5LIB} = CPANPLUS::inc->original_perl5lib;
+ #local @INC = CPANPLUS::inc->original_inc;
+
+ ### but do it *before* the new_from_context, as M::B seems
+ ### to be actually running the file...
+ ### an unshift in the block seems to be ignored.. somehow...
+ #{ my $lib = $self->best_path_to_module_build;
+ # unshift @INC, $lib if $lib;
+ #}
+ unshift @INC, $self->best_path_to_module_build
+ if $self->best_path_to_module_build;
+
+ ### this will generate warnings under anything lower than M::B 0.2606
+ my @buildflags = $dist->_buildflags_as_list( $buildflags );
+ $dist->status->_buildflags( $buildflags );
+
+ my $fail; my $prereq_fail; my $test_fail;
+ RUN: {
+
+ my $run_perl = $conf->get_program('perlwrapper');
+
+ ### this will set the directory back to the start
+ ### dir, so we must chdir /again/
+ my $ok = $dist->_resolve_prereqs(
+ force => $force,
+ format => $prereq_format,
+ verbose => $verbose,
+ prereqs => $self->status->prereqs,
+ target => $prereq_target,
+ 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->build(0);
+ $fail++; $prereq_fail++;
+ last RUN;
+ }
+
+ my ($captured, $cmd);
+ if ( ON_VMS ) {
+ $cmd = [$perl, BUILD->($dir), @buildflags];
+ }
+ else {
+ $cmd = [$perl, $run_perl, BUILD->($dir), @buildflags];
+ }
+
+ unless ( scalar run( command => $cmd,
+ buffer => \$captured,
+ verbose => $verbose )
+ ) {
+ error( loc( "MAKE failed:\n%1", $captured ) );
+ $dist->status->build(0);
+ $fail++; last RUN;
+ }
+
+ msg( $captured, 0 );
+
+ $dist->status->build(1);
+
+ ### add this directory to your lib ###
+ $self->add_to_includepath();
+
+ ### this buffer will not include what tests failed due to a
+ ### M::B/Test::Harness bug. Reported as #9793 with patch
+ ### against 0.2607 on 26/1/2005
+ unless( $skiptest ) {
+ my $test_output;
+ if ( ON_VMS ) {
+ $cmd = [$perl, BUILD->($dir), "test", @buildflags];
+ }
+ else {
+ $cmd = [$perl, $run_perl, BUILD->($dir), "test", @buildflags];
+ }
+ unless ( scalar run( command => $cmd,
+ buffer => \$test_output,
+ verbose => $verbose )
+ ) {
+ error( loc( "MAKE TEST failed:\n%1 ", $test_output ) );
+
+ ### mark specifically *test* failure.. so we dont
+ ### send success on force...
+ $test_fail++;
+
+ if( !$force and !$cb->_callbacks->proceed_on_test_failure->(
+ $self, $@ )
+ ) {
+ $dist->status->test(0);
+ $fail++; last RUN;
+ }
+
+ }
+ else {
+ msg( loc( "MAKE TEST passed:\n%1", $test_output ), 0 );
+ #msg( $test_output, 0 );
+ $dist->status->test(1);
+ }
+ }
+ else {
+ msg(loc("Tests skipped"), $verbose);
+ }
+ }
+
+ unless( $cb->_chdir( dir => $orig ) ) {
+ error( loc( "Could not chdir back to start dir '%1'", $orig ) );
+ }
+
+ ### send out test report? ###
+ 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,
+ tests_skipped => $skiptest,
+ ) or error(loc("Failed to send test report for '%1'",
+ $self->module ) );
+ }
+
+ return $dist->status->created( $fail ? 0 : 1 );
+}
+
+=head2 $dist->install([verbose => BOOL, perl => /path/to/perl])
+
+Actually installs the created dist.
+
+Returns true on success and false on failure.
+
+=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;
+
+ ### we're also the cpan_dist, since we don't need to have anything
+ ### prepared from another installer
+ $dist = $self->status->dist_cpan if $self->status->dist_cpan;
+
+ my $cb = $self->parent;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+
+ my $verbose; my $perl; my $force; my $buildflags;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ force => { default => $conf->get_conf('force'),
+ store => \$force },
+ buildflags => { default => $conf->get_conf('buildflags'),
+ store => \$buildflags },
+ perl => { default => $^X, store => \$perl },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+ $dist->status->_install_args( $args );
+ }
+
+ my $dir;
+ unless( $dir = $self->status->extract ) {
+ error( loc( "No dir found to operate on!" ) );
+ return;
+ }
+
+ my $orig = cwd();
+
+ unless( $cb->_chdir( dir => $dir ) ) {
+ error( loc( "Could not chdir to build directory '%1'", $dir ) );
+ 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;
+ }
+
+ my $fail;
+ my @buildflags = $dist->_buildflags_as_list( $buildflags );
+ my $run_perl = $conf->get_program('perlwrapper');
+
+ ### hmm, how is this going to deal with sudo?
+ ### for now, check effective uid, if it's not root,
+ ### shell out, otherwise use the method
+ if( $> ) {
+
+ ### don't worry about loading the right version of M::B anymore
+ ### the 'new_from_context' already added the 'right' path to
+ ### M::B at the top of the build.pl
+ my $cmd;
+ if ( ON_VMS ) {
+ $cmd = [$perl, BUILD->($dir), "install", @buildflags];
+ }
+ else {
+ $cmd = [$perl, $run_perl, BUILD->($dir), "install", @buildflags];
+ }
+ my $sudo = $conf->get_program('sudo');
+ unshift @$cmd, $sudo if $sudo;
+
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ buffer => \$buffer,
+ verbose => $verbose )
+ ) {
+ error(loc("Could not run '%1': %2", 'Build install', $buffer));
+ $fail++;
+ }
+ } else {
+ my ($install_output, $cmd);
+ if ( ON_VMS ) {
+ $cmd = [$perl, BUILD->($dir), "install", @buildflags];
+ }
+ else {
+ $cmd = [$perl, $run_perl, BUILD->($dir), "install", @buildflags];
+ }
+ unless( scalar run( command => $cmd,
+ buffer => \$install_output,
+ verbose => $verbose )
+ ) {
+ error(loc("Could not run '%1': %2", 'Build install', $install_output));
+ $fail++;
+ }
+ else {
+ msg( $install_output, 0 );
+ }
+ }
+
+
+ unless( $cb->_chdir( dir => $orig ) ) {
+ error( loc( "Could not chdir back to start dir '%1'", $orig ) );
+ }
+
+ return $dist->status->installed( $fail ? 0 : 1 );
+}
+
+### returns the string 'foo=bar --zot quux'
+### as the list 'foo=bar', '--zot', 'qux'
+sub _buildflags_as_list {
+ my $self = shift;
+ my $flags = shift or return;
+
+ return Module::Build->split_like_shell($flags);
+}
+
+=head1 AUTHOR
+
+Originally by Jos Boumans E<lt>kane@cpan.orgE<gt>. Brought to working
+condition by Ken Williams E<lt>kwilliams@cpan.orgE<gt>.
+
+Other hackery and currently maintained by Chris C<BinGOs> Williams ( no relation ). E<lt>bingos@cpan.orgE<gt>.
+
+=head1 LICENSE
+
+The CPAN++ interface (of which this module is a part of) is
+copyright (c) 2001, 2002, 2003, 2004, 2005 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
+
+qq[Putting the Module::Build into CPANPLUS];
+
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build/Constants.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build/Constants.pm
new file mode 100644
index 00000000000..1ac02108e44
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Build/Constants.pm
@@ -0,0 +1,69 @@
+package CPANPLUS::Dist::Build::Constants;
+
+use strict;
+use warnings;
+use File::Spec;
+
+BEGIN {
+
+ require Exporter;
+ use vars qw[$VERSION @ISA @EXPORT];
+
+ $VERSION = '0.46';
+ @ISA = qw[Exporter];
+ @EXPORT = qw[ BUILD_DIR BUILD ];
+}
+
+
+use constant BUILD_DIR => sub { return @_
+ ? File::Spec->catdir($_[0], '_build')
+ : '_build';
+ };
+use constant BUILD => sub { my $file = @_
+ ? File::Spec->catfile($_[0], 'Build')
+ : 'Build';
+
+ ### on VMS, '.com' is appended when
+ ### creating the Build file
+ $file .= '.com' if $^O eq 'VMS';
+
+ return $file;
+ };
+
+1;
+
+=head1 NAME
+
+CPANPLUS::Dist::Build::Constants - Constants for CPANPLUS::Dist::Build
+
+=head1 SYNOPSIS
+
+ use CPANPLUS::Dist::Build::Constants;
+
+=head1 DESCRIPTION
+
+CPANPLUS::Dist::Build::Constants provides some constants required by L<CPANPLUS::Dist::Build>.
+
+=head1 AUTHOR
+
+Originally by Jos Boumans E<lt>kane@cpan.orgE<gt>. Brought to working
+condition and currently maintained by Ken Williams E<lt>kwilliams@cpan.orgE<gt>.
+
+=head1 LICENSE
+
+The CPAN++ interface (of which this module is a part of) is
+copyright (c) 2001, 2002, 2003, 2004, 2005 Jos Boumans E<lt>kane@cpan.orgE<gt>.
+All rights reserved.
+
+This library is free software;
+you may redistribute and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/MM.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/MM.pm
new file mode 100644
index 00000000000..be65cd43cc8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/MM.pm
@@ -0,0 +1,1007 @@
+package CPANPLUS::Dist::MM;
+
+use warnings;
+use strict;
+use vars qw[@ISA $STATUS];
+use base 'CPANPLUS::Dist::Base';
+
+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
+
+ $mm = CPANPLUS::Dist::MM->new( 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] ) {
+ 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;
+ }
+
+ my $args;
+ my( $force, $verbose, $perl, @mmflags, $prereq_target, $prereq_format,
+ $prereq_build );
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+ my $tmpl = {
+ perl => { default => $^X, store => \$perl },
+ makemakerflags => { default =>
+ $conf->get_conf('makemakerflags') || '',
+ store => \$mmflags[0] },
+ force => { default => $conf->get_conf('force'),
+ store => \$force },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ prereq_target => { default => '', store => \$prereq_target },
+ prereq_format => { 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->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: {
+
+ ### we resolve 'configure requires' here, so we can run the 'perl
+ ### Makefile.PL' command
+ ### XXX for tests: mock f_c_r to something that *can* resolve and
+ ### something that *doesnt* resolve. Check the error log for ok
+ ### on this step or failure
+ ### XXX make a seperate tarball to test for this scenario: simply
+ ### containing a makefile.pl/build.pl for test purposes?
+ { my $configure_requires = $dist->find_configure_requires;
+ my $ok = $dist->_resolve_prereqs(
+ format => $prereq_format,
+ verbose => $verbose,
+ prereqs => $configure_requires,
+ target => $prereq_target,
+ force => $force,
+ prereq_build => $prereq_build,
+ );
+
+ unless( $ok ) {
+
+ #### use $dist->flush to reset the cache ###
+ error( loc( "Unable to satisfy '%1' for '%2' " .
+ "-- aborting install",
+ 'configure_requires', $self->module ) );
+ $dist->status->prepared(0);
+ $fail++;
+ last RUN;
+ }
+ ### end of prereq resolving ###
+ }
+
+
+
+ ### 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 = MAKEFILE_PL->( $cb->_safe_path( path => $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;
+
+ ### see if we got prereqs from MYMETA
+ my $prereqs = $dist->find_mymeta_requires();
+
+ ### we found some prereqs, we'll trust MYMETA
+ ### but we do need to run it through the callback
+ return $cb->_callbacks->filter_prereqs->( $cb, $prereqs ) if keys %$prereqs;
+
+ my $fh = FileHandle->new();
+ unless( $fh->open( $file ) ) {
+ error( loc( "Cannot open '%1': %2", $file, $! ) );
+ return;
+ }
+
+ my %p;
+ while( local $_ = <$fh> ) {
+ my ($found) = m|^[\#]\s+PREREQ_PM\s+=>\s+(.+)|;
+
+ next unless $found;
+
+ while( $found =~ m/(?:\s)([\w\:]+)=>(?:q\[(.*?)\],?|undef)/g ) {
+ if( defined $p{$1} ) {
+ my $ver = $cb->_version_to_number(version => $2);
+ $p{$1} = $ver
+ if $cb->_vcmp( $ver, $p{$1} ) > 0;
+ }
+ else {
+ $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?
+ ### make sure we add to include path again, just in case we came from
+ ### ->save_state, at which point we need to restore @INC/$PERL5LIB
+ if( $dist->status->created && !$force ) {
+ $self->add_to_includepath;
+ return 1;
+ }
+
+ ### 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: %1", $captured ), 0 );
+ }
+
+ $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++;
+
+ if( !$force and !$cb->_callbacks->proceed_on_test_failure->(
+ $self, $captured )
+ ) {
+ $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/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Sample.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Sample.pm
new file mode 100644
index 00000000000..0b0939208ff
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Dist/Sample.pm
@@ -0,0 +1,16 @@
+package CPANPLUS::Dist::Sample;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Dist::Sample -- Sample code to create your own Dist::* plugin
+
+=head1 Description.
+
+This document is B<Obsolete>. Please read the documentation and code
+in C<CPANPLUS::Dist::Base>.
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Error.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Error.pm
new file mode 100644
index 00000000000..38710a8a857
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Error.pm
@@ -0,0 +1,201 @@
+package CPANPLUS::Error;
+
+use strict;
+
+use Log::Message private => 0;;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Error
+
+=head1 SYNOPSIS
+
+ use CPANPLUS::Error qw[cp_msg cp_error];
+
+=head1 DESCRIPTION
+
+This module provides the error handling code for the CPANPLUS
+libraries, and is mainly intended for internal use.
+
+=head1 FUNCTIONS
+
+=head2 cp_msg("message string" [,VERBOSE])
+
+Records a message on the stack, and prints it to C<STDOUT> (or actually
+C<$MSG_FH>, see the C<GLOBAL VARIABLES> section below), if the
+C<VERBOSE> option is true.
+The C<VERBOSE> option defaults to false.
+
+=head2 msg()
+
+An alias for C<cp_msg>.
+
+=head2 cp_error("error string" [,VERBOSE])
+
+Records an error on the stack, and prints it to C<STDERR> (or actually
+C<$ERROR_FH>, see the C<GLOBAL VARIABLES> sections below), if the
+C<VERBOSE> option is true.
+The C<VERBOSE> options defaults to true.
+
+=head2 error()
+
+An alias for C<cp_error>.
+
+=head1 CLASS METHODS
+
+=head2 CPANPLUS::Error->stack()
+
+Retrieves all the items on the stack. Since C<CPANPLUS::Error> is
+implemented using C<Log::Message>, consult its manpage for the
+function C<retrieve> to see what is returned and how to use the items.
+
+=head2 CPANPLUS::Error->stack_as_string([TRACE])
+
+Returns the whole stack as a printable string. If the C<TRACE> option is
+true all items are returned with C<Carp::longmess> output, rather than
+just the message.
+C<TRACE> defaults to false.
+
+=head2 CPANPLUS::Error->flush()
+
+Removes all the items from the stack and returns them. Since
+C<CPANPLUS::Error> is implemented using C<Log::Message>, consult its
+manpage for the function C<retrieve> to see what is returned and how
+to use the items.
+
+=cut
+
+BEGIN {
+ use Exporter;
+ use Params::Check qw[check];
+ use vars qw[@EXPORT @ISA $ERROR_FH $MSG_FH];
+
+ @ISA = 'Exporter';
+ @EXPORT = qw[cp_error cp_msg error msg];
+
+ my $log = new Log::Message;
+
+ for my $func ( @EXPORT ) {
+ no strict 'refs';
+
+ my $prefix = 'cp_';
+ my $name = $func;
+ $name =~ s/^$prefix//g;
+
+ *$func = sub {
+ my $msg = shift;
+
+ ### no point storing non-messages
+ return unless defined $msg;
+
+ $log->store(
+ message => $msg,
+ tag => uc $name,
+ level => $prefix . $name,
+ extra => [@_]
+ );
+ };
+ }
+
+ sub flush {
+ return reverse $log->flush;
+ }
+
+ sub stack {
+ return $log->retrieve( chrono => 1 );
+ }
+
+ sub stack_as_string {
+ my $class = shift;
+ my $trace = shift() ? 1 : 0;
+
+ return join $/, map {
+ '[' . $_->tag . '] [' . $_->when . '] ' .
+ ($trace ? $_->message . ' ' . $_->longmess
+ : $_->message);
+ } __PACKAGE__->stack;
+ }
+}
+
+=head1 GLOBAL VARIABLES
+
+=over 4
+
+=item $ERROR_FH
+
+This is the filehandle all the messages sent to C<error()> are being
+printed. This defaults to C<*STDERR>.
+
+=item $MSG_FH
+
+This is the filehandle all the messages sent to C<msg()> are being
+printed. This default to C<*STDOUT>.
+
+=cut
+local $| = 1;
+$ERROR_FH = \*STDERR;
+$MSG_FH = \*STDOUT;
+
+package Log::Message::Handlers;
+use Carp ();
+
+{
+
+ sub cp_msg {
+ my $self = shift;
+ my $verbose = shift;
+
+ ### so you don't want us to print the msg? ###
+ return if defined $verbose && $verbose == 0;
+
+ my $old_fh = select $CPANPLUS::Error::MSG_FH;
+
+ print '['. $self->tag . '] ' . $self->message . "\n";
+ select $old_fh;
+
+ return;
+ }
+
+ sub cp_error {
+ my $self = shift;
+ my $verbose = shift;
+
+ ### so you don't want us to print the error? ###
+ return if defined $verbose && $verbose == 0;
+
+ my $old_fh = select $CPANPLUS::Error::ERROR_FH;
+
+ ### is only going to be 1 for now anyway ###
+ ### C::I may not be loaded, so do a can() check first
+ my $cb = CPANPLUS::Internals->can('_return_all_objects')
+ ? (CPANPLUS::Internals->_return_all_objects)[0]
+ : undef;
+
+ ### maybe we didn't initialize an internals object (yet) ###
+ my $debug = $cb ? $cb->configure_object->get_conf('debug') : 0;
+ my $msg = '['. $self->tag . '] ' . $self->message . "\n";
+
+ ### i'm getting this warning in the test suite:
+ ### Ambiguous call resolved as CORE::warn(), qualify as such or
+ ### use & at CPANPLUS/Error.pm line 57.
+ ### no idea where it's coming from, since there's no 'sub warn'
+ ### anywhere to be found, but i'll mark it explicitly nonetheless
+ ### --kane
+ print $debug ? Carp::shortmess($msg) : $msg . "\n";
+
+ select $old_fh;
+
+ return;
+ }
+}
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/FAQ.pod b/Master/tlpkg/tlperl/lib/CPANPLUS/FAQ.pod
new file mode 100644
index 00000000000..82bb57aaf47
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/FAQ.pod
@@ -0,0 +1,30 @@
+=pod
+
+=head1 NAME
+
+CPANPLUS::FAQ
+
+=head1 DESCRIPTION
+
+This document attempts to provide answers to commonly asked questions.
+
+ XXX Work in progress
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Hacking.pod b/Master/tlpkg/tlperl/lib/CPANPLUS/Hacking.pod
new file mode 100644
index 00000000000..1a28b9e5b05
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Hacking.pod
@@ -0,0 +1,135 @@
+=pod
+
+=head1 NAME
+
+CPANPLUS::Hacking
+
+=head1 DESCRIPTION
+
+This document attempts to describe how to develop with the
+CPANPLUS environment most easily, 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
+
+Checkout CPANPLUS from its Subversion repository at
+L<http://oss.dwim.org/cpanplus-devel> .
+
+=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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals.pm
new file mode 100644
index 00000000000..fedcb670aa4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals.pm
@@ -0,0 +1,516 @@
+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::Extract;
+use CPANPLUS::Internals::Fetch;
+use CPANPLUS::Internals::Utils;
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Internals::Search;
+use CPANPLUS::Internals::Report;
+
+
+require base;
+use Cwd qw[cwd];
+use Module::Load qw[load];
+use Params::Check qw[check];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+use Module::Load::Conditional qw[can_load];
+
+use Object::Accessor;
+
+
+local $Params::Check::VERBOSE = 1;
+
+use vars qw[@ISA $VERSION];
+
+@ISA = qw[
+ CPANPLUS::Internals::Extract
+ CPANPLUS::Internals::Fetch
+ CPANPLUS::Internals::Utils
+ CPANPLUS::Internals::Search
+ CPANPLUS::Internals::Report
+ ];
+
+$VERSION = "0.90";
+
+=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
+
+=cut
+
+### autogenerate accessors ###
+for my $key ( qw[_conf _id _modules _hosts _methods _status
+ _callbacks _selfupdate _mtree _atree]
+) {
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ $_[0]->{$key} = $_[1] if @_ > 1;
+ return $_[0]->{$key};
+ }
+}
+
+=pod
+
+=back
+
+=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] },
+ # continue if 'make test' fails?
+ proceed_on_test_failure => sub { return 0 },
+ munge_dist_metafile => 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 },
+ _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 ] .
+ qq[running program\n], '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( {} );
+
+ $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) );
+ }
+
+ ### different source engines available now, so set them here
+ { my $store = $conf->get_conf( 'source_engine' )
+ || DEFAULT_SOURCE_ENGINE;
+
+ unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) {
+ error( loc( "Could not load source engine '%1'", $store ) );
+
+ if( $store ne DEFAULT_SOURCE_ENGINE ) {
+ msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 );
+
+ load DEFAULT_SOURCE_ENGINE;
+
+ base->import( DEFAULT_SOURCE_ENGINE );
+ } else {
+ return;
+ }
+ } else {
+ base->import( $store );
+ }
+ }
+
+ 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 $conf = $self->configure_object;
+ 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} = $conf->_perl5lib || '';
+ @INC = @{$conf->_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.
+
+=item proceed_on_test_failure
+
+Is called when 'make test' or 'Build test' fails. Should return
+a boolean indicating whether the install should continue even if
+the test failed.
+
+=item munge_dist_metafile
+
+Is called when the C<CPANPLUS::Dist::*> metafile is created, like
+C<control> for C<CPANPLUS::Dist::Deb>, giving the user a chance to
+programatically alter it. Should return the (munged) text to be
+written to the metafile.
+
+=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;
+
+ my $s = $Config{'path_sep'};
+
+ ### only add if it's not added yet
+ for my $lib (@$dirs) {
+ push @INC, $lib unless grep { $_ eq $lib } @INC;
+ #
+ ### it will be complaining if $ENV{PERL5LIB] is not defined (yet).
+ local $^W;
+ $ENV{'PERL5LIB'} .= $s . $lib
+ unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|;
+ }
+
+ 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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm
new file mode 100644
index 00000000000..1a38200dfb7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants.pm
@@ -0,0 +1,375 @@
+package CPANPLUS::Internals::Constants;
+
+use strict;
+
+use CPANPLUS::Error;
+
+use Config;
+use File::Spec;
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+require Exporter;
+use vars qw[$VERSION @ISA @EXPORT];
+
+use Package::Constants;
+
+@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 INSTALLER_AUTOBUNDLE
+ => 'CPANPLUS::Dist::Autobundle';
+
+use constant SHELL_DEFAULT => 'CPANPLUS::Shell::Default';
+use constant SHELL_CLASSIC => 'CPANPLUS::Shell::Classic';
+
+use constant CONFIG => 'CPANPLUS::Config';
+use constant CONFIG_USER => 'CPANPLUS::Config::User';
+use constant CONFIG_SYSTEM => 'CPANPLUS::Config::System';
+use constant CONFIG_BOXED => 'CPANPLUS::Config::Boxed';
+
+use constant DEFAULT_SOURCE_ENGINE
+ => 'CPANPLUS::Internals::Source::Memory';
+
+use constant TARGET_INIT => 'init';
+use constant TARGET_CREATE => 'create';
+use constant TARGET_PREPARE => 'prepare';
+use constant TARGET_INSTALL => 'install';
+use constant TARGET_IGNORE => 'ignore';
+
+use constant ON_WIN32 => $^O eq 'MSWin32';
+use constant ON_NETWARE => $^O eq 'NetWare';
+use constant ON_CYGWIN => $^O eq 'cygwin';
+use constant ON_VMS => $^O eq 'VMS';
+
+use constant DOT_CPANPLUS => ON_VMS ? '_cpanplus' : '.cpanplus';
+
+use constant OPT_AUTOFLUSH => '-MCPANPLUS::Internals::Utils::Autoflush';
+
+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;
+ };
+
+ ### On VMS, if the $Config{make} is either MMK
+ ### or MMS, then the makefile is 'DESCRIP.MMS'.
+use constant MAKEFILE => sub { my $file =
+ (ON_VMS and
+ $Config::Config{make} =~ /MM[S|K]/i)
+ ? 'DESCRIP.MMS'
+ : 'Makefile';
+
+ return @_
+ ? File::Spec->catfile( @_, $file )
+ : $file;
+ };
+use constant MAKEFILE_PL => sub { return @_
+ ? File::Spec->catfile( @_,
+ 'Makefile.PL' )
+ : 'Makefile.PL';
+ };
+use constant BUILD_PL => sub { return @_
+ ? File::Spec->catfile( @_,
+ 'Build.PL' )
+ : 'Build.PL';
+ };
+
+use constant META_YML => sub { return @_
+ ? File::Spec->catfile( @_, 'META.yml' )
+ : 'META.yml';
+ };
+
+use constant MYMETA_YML => sub { return @_
+ ? File::Spec->catfile( @_, 'MYMETA.yml' )
+ : 'MYMETA.yml';
+ };
+
+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 META_EXT => 'meta';
+
+use constant META => sub { my $obj = $_[0];
+ my $pkg = $obj->package_name;
+ $pkg .= '-' . $obj->package_version .
+ '.' . META_EXT;
+ 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 OPEN_DIR => sub {
+ my $dir = shift;
+ my $dh;
+ opendir $dh, $dir or error(loc(
+ "Could not open dir '%1': %2", $dir, $!
+ ));
+
+ return $dh if $dh;
+ return;
+ };
+
+use constant READ_DIR => sub {
+ my $dir = shift;
+ my $dh = OPEN_DIR->( $dir ) or return;
+
+ ### exclude . and ..
+ my @files = grep { $_ !~ /^\.{1,2}/ }
+ readdir($dh);
+
+ ### Remove trailing dot on VMS when
+ ### using VMS syntax.
+ if( ON_VMS ) {
+ s/(?<!\^)\.$// for @files;
+ }
+
+ return @files;
+ };
+
+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://cpantesters.org/distro/'.
+ uc(substr($_[0],0,1)) .'/'. $_[0] . '.yaml';
+ };
+use constant TESTERS_DETAILS_URL
+ => sub {
+ 'http://cpantesters.org/distro/'.
+ uc(substr($_[0],0,1)) .'/'. $_[0];
+ };
+
+use constant CREATE_FILE_URI
+ => sub {
+ my $dir = $_[0] or return;
+ return $dir =~ m|^/|
+ ? 'file://' . $dir
+ : 'file:///' . $dir;
+ };
+
+use constant EMPTY_DSLIP => ' ';
+
+use constant CUSTOM_AUTHOR_ID
+ => 'LOCAL';
+
+use constant DOT_SHELL_DEFAULT_RC
+ => '.shell-default.rc';
+
+use constant SOURCE_SQLITE_DB
+ => 'db.sql';
+
+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 STORABLE_EXT => '.stored';
+
+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_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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm
new file mode 100644
index 00000000000..59a41a6083b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Constants/Report.pm
@@ -0,0 +1,407 @@
+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;
+
+### for the version
+require CPANPLUS::Internals;
+
+$VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION;
+@ISA = qw[Exporter];
+@EXPORT = Package::Constants->list( __PACKAGE__ );
+
+
+### 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 $last = ( split /\[ERROR\] .+? MAKE TEST/, $buffer )[-1];
+ my @list = map { s/.pm$//; s|/|::|g; $_ }
+ ($last =~
+ m/\bCan\'t locate (\S+) in \@INC/g);
+
+ ### make sure every missing prereq is only
+ ### listed once
+ { 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
+ }
+);
+
+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 { sprintf "\t%s %-30s %8s %8s\n",
+ @$_
+
+ } [' ', 'Module Name', 'Have', 'Want'],
+ map { my $want = $prq->{$_->name};
+ [ do { $_->is_uptodate(
+ version => $want
+ ) ? ' ' : '!'
+ },
+ $_->name,
+ $_->installed_version,
+ $want
+ ],
+ ### might be empty entries in there
+ } grep { $_ } @prq;
+
+ return $str;
+ };
+
+use constant REPORT_TOOLCHAIN_VERSIONS
+ => sub {
+ my $mod = shift;
+ my $cb = $mod->parent;
+ #die unless $cb->isa('CPANPLUS::Backend');
+
+ my @toolchain_modules= qw(
+ CPANPLUS
+ CPANPLUS::Dist::Build
+ Cwd
+ ExtUtils::CBuilder
+ ExtUtils::Command
+ ExtUtils::Install
+ ExtUtils::MakeMaker
+ ExtUtils::Manifest
+ ExtUtils::ParseXS
+ File::Spec
+ Module::Build
+ Test::Harness
+ Test::More
+ version
+ );
+
+ my @toolchain =
+ grep { $_ } #module_tree returns '' when module is not found
+ map { $cb->module_tree($_) }
+ sort @toolchain_modules;
+
+ ### no prereqs?
+ return '' unless @toolchain;
+
+ ### toolchain modules
+ my $str = << ".";
+
+Perl module toolchain versions installed:
+.
+ $str .= join '',
+ map { sprintf "\t%-30s %8s\n",
+ @$_
+
+ } ['Module Name', 'Have'],
+ map {
+ [ $_->name,
+ $_->installed_version,
+ ],
+ ### might be empty entries in there
+ } @toolchain;
+
+ 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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm
new file mode 100644
index 00000000000..84a48a50dea
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Extract.pm
@@ -0,0 +1,243 @@
+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->catfile($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(
+ ### _safe_path must be called before catdir because catdir on
+ ### VMS currently will not handle the extra dots in the directories.
+ File::Spec->catdir( $self->_safe_path( path => $to ) ,
+ $self->_safe_path( path =>
+ $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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm
new file mode 100644
index 00000000000..395965bab60
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Fetch.pm
@@ -0,0 +1,473 @@
+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, ttl => $seconds] )
+
+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<ttl> (in seconds) indicates how long a cached copy is valid for. If
+the fetch time of the local copy is within the ttl, the cached copy is
+returned. Otherwise, the file is refetched.
+
+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, $ttl);
+ 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') },
+ ttl => { default => 0, store => \$ttl },
+ };
+
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ ### check if we already downloaded the thing ###
+ if( (my $where = $modobj->status->fetch()) and not $force and not $ttl ) {
+
+ 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 so, can we use the cached version,
+ ### or do we need to refetch?
+ if( -e $local_file ) {
+
+ my $unlink = 0;
+ my $use_cached = 0;
+
+ ### if force is in effect, we have to refetch
+ if( $force ) {
+ $unlink++
+
+ ### if you provided a ttl, and it was exceeded, we'll refetch,
+ } elsif( $ttl and ([stat $local_file]->[9] + $ttl > time) ) {
+ msg(loc("Using cached file '%1' on disk; ".
+ "ttl (%2s) is not exceeded",
+ $local_file, $ttl), $verbose );
+
+ $use_cached++;
+
+ ### if you provided a ttl, and the above conditional didn't match,
+ ### we exceeded the ttl, so we refetch
+ } elsif ( $ttl ) {
+ $unlink++;
+
+ ### otherwise we can use the cached version
+ } else {
+ $use_cached++;
+ }
+
+ if( $unlink ) {
+ ### some fetches will fail if the files exist already, so let's
+ ### delete them first
+ 1 while unlink $local_file;
+
+ msg(loc("Could not delete %1, some methods may " .
+ "fail to force a download", $local_file), $verbose)
+ if -e $local_file;
+
+ } 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 $where;
+
+ ### file:// uris are special and need parsing
+ if( $host->{'scheme'} eq 'file' ) {
+
+ ### the full path in the native format of the OS
+ my $host_spec =
+ File::Spec->file_name_is_absolute( $host->{'path'} )
+ ? $host->{'path'}
+ : File::Spec->rel2abs( $host->{'path'} );
+
+ ### there might be volumes involved on vms/win32
+ if( ON_WIN32 or ON_VMS ) {
+
+ ### now extract the volume in order to be Win32 and
+ ### VMS friendly.
+ ### 'no_file' indicates that there's no file part
+ ### of this path, so we only get 2 bits returned.
+ my ($vol, $host_path) = File::Spec->splitpath(
+ $host_spec, 'no_file'
+ );
+
+ ### and split up the directories
+ my @host_dirs = File::Spec->splitdir( $host_path );
+
+ ### if we got a volume we pretend its a directory for
+ ### the sake of the file:// url
+ if( defined $vol and $vol ) {
+
+ ### D:\foo\bar needs to be encoded as D|\foo\bar
+ ### For details, see the following link:
+ ### http://en.wikipedia.org/wiki/File://
+ ### The RFC doesnt seem to address Windows volume
+ ### descriptors but it does address VMS volume
+ ### descriptors, however wikipedia covers a bit of
+ ### history regarding win32
+ $vol =~ s/:$/|/ if ON_WIN32;
+
+ $vol =~ s/:// if ON_VMS;
+
+ ### XXX i'm not sure what cases this is addressing.
+ ### this comes straight from dmq's file:// patches
+ ### for win32. --kane
+ ### According to dmq, the best summary is:
+ ### "if file:// urls dont look right on VMS reuse
+ ### the win32 logic and see if that fixes things"
+
+ ### first element not empty? Might happen on VMS.
+ ### prepend the volume in that case.
+ if( $host_dirs[0] ) {
+ unshift @host_dirs, $vol;
+
+ ### element empty? reuse it to store the volume
+ ### encoded as a directory name. (Win32/VMS)
+ } else {
+ $host_dirs[0] = $vol;
+ }
+ }
+
+ ### now it's in UNIX format, which is the same format
+ ### as used for URIs
+ $host_spec = File::Spec::Unix->catdir( @host_dirs );
+ }
+
+ ### now create the file:// uri from the components
+ $where = CREATE_FILE_URI->(
+ File::Spec::Unix->catfile(
+ $host->{'host'} || '',
+ $host_spec,
+ $remote_file,
+ )
+ );
+
+ ### its components will be in unix format, for a http://,
+ ### ftp:// or any other style of URI
+ } else {
+ my $mirror_path = File::Spec::Unix->catfile(
+ $host->{'path'}, $remote_file
+ );
+
+ 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 );
+
+ ### so TTLs will work
+ $self->_update_timestamp( file => $abs );
+
+ 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/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm
new file mode 100644
index 00000000000..774c6b91a02
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm
@@ -0,0 +1,645 @@
+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 Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+$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
+
+### XXX remove this list and move it into selfupdate, somehow..
+### this is dual administration
+{ my $query_list = {
+ 'File::Fetch' => '0.13_02',
+ 'Parse::CPAN::Meta' => '0.0',
+ 'File::Temp' => '0.0',
+ };
+
+ my $send_list = {
+ %$query_list,
+ 'Test::Reporter' => '1.34',
+ };
+
+ 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. The contents of the
+data structure depends on what I<http://testers.cpan.org> returns,
+but generally looks like this:
+
+ {
+ 'grade' => 'PASS',
+ 'dist' => 'CPANPLUS-0.042',
+ 'platform' => 'i686-pld-linux-thread-multi'
+ 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/98316'
+ ...
+ },
+ {
+ 'grade' => 'PASS',
+ 'dist' => 'CPANPLUS-0.042',
+ 'platform' => 'i686-linux-thread-multi'
+ 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99416'
+ ...
+ },
+ {
+ '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 );
+
+
+ ### XXX no longer use LWP here. However, that means we don't
+ ### automagically set proxies anymore!!!
+ # my $ua = LWP::UserAgent->new;
+ # $ua->agent( CPANPLUS_UA->() );
+ #
+ ### set proxies if we have them ###
+ # $ua->env_proxy();
+
+ my $url = TESTERS_URL->($mod->package_name);
+ my $ff = File::Fetch->new( uri => $url );
+
+ msg( loc("Fetching: '%1'", $url), $verbose );
+
+ my $res = do {
+ my $tempdir = File::Temp::tempdir();
+ my $where = $ff->fetch( to => $tempdir );
+
+ unless( $where ) {
+ error( loc( "Fetching report for '%1' failed: %2",
+ $url, $ff->error ) );
+ return;
+ }
+
+ my $fh = OPEN_FILE->( $where );
+
+ do { local $/; <$fh> };
+ };
+
+ my ($aref) = eval { Parse::CPAN::Meta::Load( $res ) };
+
+ if( $@ ) {
+ error(loc("Error reading result: %1", $@));
+ return;
+ };
+
+ my $dist = $mod->package_name .'-'. $mod->package_version;
+ my $details = TESTERS_DETAILS_URL->($mod->package_name);
+
+ my @rv;
+ for my $href ( @$aref ) {
+ next unless $all or defined $href->{'distversion'} &&
+ $href->{'distversion'} eq $dist;
+
+ $href->{'details'} = $details;
+
+ ### backwards compatibility :(
+ $href->{'dist'} ||= $href->{'distversion'};
+ $href->{'grade'} ||= $href->{'action'} || $href->{'status'};
+
+ push @rv, $href;
+ }
+
+ return @rv if @rv;
+ return;
+}
+
+=pod
+
+=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, 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 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,
+ $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 },
+ 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;
+
+
+ ### will be 'fetch', 'make', 'test', 'install', etc ###
+ my $stage = TEST_FAIL_STAGE->($buffer);
+
+ ### 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 );
+ my $sub = CPANPLUS::Module->can(
+ 'module_is_supplied_with_perl_core' );
+
+ ### if we can't find the module and it's not supplied with core.
+ ### this addresses: #32064: NA reports generated for failing
+ ### tests where core prereqs are specified
+ ### Note that due to a bug in Module::CoreList, in some released
+ ### version of perl (5.8.6+ and 5.9.2-4 at the time of writing)
+ ### 'Config' is not recognized as a core module. See this bug:
+ ### http://rt.cpan.org/Ticket/Display.html?id=32155
+ if( !$obj and !$sub->( $prq_name ) ) {
+ 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 ( !$obj ) {
+ my $vcore = $sub->( $prq_name );
+ if ( $cb->_vcmp( $prq_ver, $vcore ) > 0 ) {
+ msg(loc( "Version of core module '%1' ('%2') is too low for ".
+ "'%3' (needs '%4') -- sending N/A grade",
+ $prq_name, $vcore,
+ $name, $prq_ver ), $verbose );
+
+ $grade = GRADE_NA;
+ last GRADE;
+ }
+ }
+
+ if( $obj and $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;
+ ### failures in PL or make/build stage are now considered UNKNOWN
+ } elsif ( $stage !~ /\btest\b/ ) {
+
+ $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 ###
+
+ ### the header -- always include so the CPANPLUS version is apparent
+ my $message = REPORT_MESSAGE_HEADER->( $int_ver, $author );
+
+ 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;
+ }
+
+ ### 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 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);
+
+ ### add a list of versions of toolchain modules
+ $message .= REPORT_TOOLCHAIN_VERSIONS->($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->();
+ } elsif( $grade eq GRADE_NA) {
+
+ ### the bit where we inform what went wrong
+ $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );
+
+ ### the footer
+ $message .= REPORT_MESSAGE_FOOTER->();
+
+ }
+
+ msg( loc("Sending test report for '%1'", $dist), $verbose);
+
+ ### reporter object ###
+ my $reporter = do {
+ my $args = $conf->get_conf('cpantest_reporter_args') || {};
+
+ unless( UNIVERSAL::isa( $args, 'HASH' ) ) {
+ error(loc("'%1' must be a hashref, ignoring...",
+ 'cpantest_reporter_args'));
+ $args = {};
+ }
+
+ Test::Reporter->new(
+ grade => $grade,
+ distribution => $dist,
+ via => "CPANPLUS $int_ver",
+ timeout => $conf->get_conf('timeout') || 60,
+ debug => $conf->get_conf('debug'),
+ %$args,
+ );
+ };
+
+ ### set a custom mx, if requested
+ $reporter->mx( [ $conf->get_conf('cpantest_mx') ] )
+ if $conf->get_conf('cpantest_mx');
+
+ ### set the from address ###
+ $reporter->from( $conf->get_conf('email') )
+ if $conf->get_conf('email') !~ /\@example\.\w+$/i;
+
+ ### give the user a chance to programattically alter the message
+ $message = $self->_callbacks->munge_test_report->($mod, $message, $grade);
+
+ ### add the body if we have any ###
+ $reporter->comments( $message ) if defined $message && length $message;
+
+ ### do a callback to ask if we should send the report
+ unless ($self->_callbacks->send_test_report->($mod, $grade)) {
+ msg(loc("Ok, not sending test report"));
+ return 1;
+ }
+
+ ### do a callback to ask if we should edit the report
+ if ($self->_callbacks->edit_test_report->($mod, $grade)) {
+ ### test::reporter 1.20 and lower don't have a way to set
+ ### the preferred editor with a method call, but it does
+ ### respect your env variable, so let's set that.
+ local $ENV{VISUAL} = $conf->get_program('editor')
+ if $conf->get_program('editor');
+
+ $reporter->edit_comments;
+ }
+
+ ### allow to be overridden, but default to the normal address ###
+ $reporter->address( $address );
+
+ ### should we save it locally? ###
+ if( $save ) {
+ if( my $file = $reporter->write() ) {
+ msg(loc("Successfully wrote report for '%1' to '%2'",
+ $dist, $file), $verbose);
+ return $file;
+
+ } else {
+ error(loc("Failed to write report for '%1'", $dist));
+ return;
+ }
+
+ ### XXX should we do an 'already sent' check? ###
+ ### something broke :( ###
+ }
+ else {
+ my $status;
+ eval {
+ $status = $reporter->send();
+ };
+ if ( $@ ) {
+ error(loc("Could not send '%1' report for '%2': %3",
+ $grade, $dist, $@));
+ return;
+ }
+ if ( $status ) {
+ msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist),
+ $verbose);
+ return 1;
+ }
+ error(loc("Could not send '%1' report for '%2': %3",
+ $grade, $dist, $reporter->errstr));
+ return;
+ }
+}
+
+sub _verify_missing_prereqs {
+ my $self = shift;
+ my %hash = @_;
+
+ ### check arguments ###
+ my ($mod, $missing);
+ my $tmpl = {
+ module => { required => 1, store => \$mod },
+ missing => { required => 1, store => \$missing },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+
+ my %missing = map {$_ => 1} @$missing;
+ my $conf = $self->configure_object;
+ my $extract = $mod->status->extract;
+
+ ### Read pre-requisites from Makefile.PL or Build.PL (if there is one),
+ ### of the form:
+ ### 'PREREQ_PM' => {
+ ### 'Compress::Zlib' => '1.20',
+ ### 'Test::More' => 0,
+ ### },
+ ### Build.PL uses 'requires' instead of 'PREREQ_PM'.
+
+ my @search;
+ push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->());
+ push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->());
+
+ for my $file ( @search ) {
+ if(-e $file and -r $file) {
+ my $slurp = $self->_get_file_contents(file => $file);
+ my ($prereq) =
+ ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s);
+ my @prereq =
+ ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg);
+ delete $missing{$_} for(@prereq);
+ }
+ }
+
+ return 1 if(keys %missing); # There ARE missing prerequisites
+ return; # All prerequisites accounted for
+}
+
+1;
+
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm
new file mode 100644
index 00000000000..63c4da64d92
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Search.pm
@@ -0,0 +1,363 @@
+package CPANPLUS::Internals::Search;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Module;
+use CPANPLUS::Module::Author;
+
+use File::Find;
+use File::Spec;
+
+use Params::Check qw[check allow];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+$Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Internals::Search
+
+=head1 SYNOPSIS
+
+ my $aref = $cpan->_search_module_tree(
+ type => 'package',
+ allow => [qr/DBI/],
+ );
+
+ my $aref = $cpan->_search_author_tree(
+ type => 'cpanid',
+ data => \@old_results,
+ verbose => 1,
+ allow => [qw|KANE AUTRIJUS|],
+ );
+
+ my $aref = $cpan->_all_installed( );
+
+=head1 DESCRIPTION
+
+The functions in this module are designed to find module(objects)
+based on certain criteria and return them.
+
+=head1 METHODS
+
+=head2 _search_module_tree( type => TYPE, allow => \@regexes, [data => \@previous_results ] )
+
+Searches the moduletree for module objects matching the criteria you
+specify. Returns an array ref of module objects on success, and false
+on failure.
+
+It takes the following arguments:
+
+=over 4
+
+=item type
+
+This can be any of the accessors for the C<CPANPLUS::Module> objects.
+This is a required argument.
+
+=item allow
+
+A set of rules, or more precisely, a list of regexes (via C<qr//> or
+plain strings), that the C<type> must adhere too. You can specify as
+many as you like, and it will be treated as an C<OR> search.
+For an C<AND> search, see the C<data> argument.
+
+This is a required argument.
+
+=item data
+
+An arrayref of previous search results. This is the way to do an C<AND>
+search -- C<_search_module_tree> will only search the module objects
+specified in C<data> if provided, rather than the moduletree itself.
+
+=back
+
+=cut
+
+# Although the Params::Check solution is more graceful, it is WAY too slow.
+#
+# This sample script:
+#
+# use CPANPLUS::Backend;
+# my $cb = new CPANPLUS::Backend;
+# $cb->module_tree;
+# my @list = $cb->search( type => 'module', allow => [qr/^Acme/] );
+# print $_->module, $/ for @list;
+#
+# Produced the following output using Dprof WITH params::check code
+#
+# Total Elapsed Time = 3.670024 Seconds
+# User+System Time = 3.390373 Seconds
+# Exclusive Times
+# %Time ExclSec CumulS #Calls sec/call Csec/c Name
+# 88.7 3.008 4.463 20610 0.0001 0.0002 Params::Check::check
+# 47.4 1.610 1.610 1 1.6100 1.6100 Storable::net_pstore
+# 25.6 0.869 0.737 20491 0.0000 0.0000 Locale::Maketext::Simple::_default
+# _gettext
+# 23.2 0.789 0.524 40976 0.0000 0.0000 Params::Check::_who_was_it
+# 23.2 0.789 0.677 20610 0.0000 0.0000 Params::Check::_sanity_check
+# 19.7 0.670 0.670 1 0.6700 0.6700 Storable::pretrieve
+# 14.1 0.480 0.211 41350 0.0000 0.0000 Params::Check::_convert_case
+# 11.5 0.390 0.256 20610 0.0000 0.0000 Params::Check::_hashdefs
+# 11.5 0.390 0.255 20697 0.0000 0.0000 Params::Check::_listreqs
+# 11.4 0.389 0.177 20653 0.0000 0.0000 Params::Check::_canon_key
+# 10.9 0.370 0.356 20697 0.0000 0.0000 Params::Check::_hasreq
+# 8.02 0.272 4.750 1 0.2723 4.7501 CPANPLUS::Internals::Search::_sear
+# ch_module_tree
+# 6.49 0.220 0.086 20653 0.0000 0.0000 Params::Check::_iskey
+# 6.19 0.210 0.077 20488 0.0000 0.0000 Params::Check::_store_error
+# 5.01 0.170 0.036 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__
+#
+# and this output /without/
+#
+# Total Elapsed Time = 2.803426 Seconds
+# User+System Time = 2.493426 Seconds
+# Exclusive Times
+# %Time ExclSec CumulS #Calls sec/call Csec/c Name
+# 56.9 1.420 1.420 1 1.4200 1.4200 Storable::net_pstore
+# 25.6 0.640 0.640 1 0.6400 0.6400 Storable::pretrieve
+# 9.22 0.230 0.096 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__
+# 7.06 0.176 0.272 1 0.1762 0.2719 CPANPLUS::Internals::Search::_sear
+# ch_module_tree
+# 3.21 0.080 0.098 10 0.0080 0.0098 IPC::Cmd::BEGIN
+# 1.60 0.040 0.205 13 0.0031 0.0158 CPANPLUS::Internals::BEGIN
+# 1.20 0.030 0.030 29 0.0010 0.0010 vars::BEGIN
+# 1.20 0.030 0.117 10 0.0030 0.0117 Log::Message::BEGIN
+# 1.20 0.030 0.029 9 0.0033 0.0033 CPANPLUS::Internals::Search::BEGIN
+# 0.80 0.020 0.020 5 0.0040 0.0040 DynaLoader::dl_load_file
+# 0.80 0.020 0.127 10 0.0020 0.0127 CPANPLUS::Module::BEGIN
+# 0.80 0.020 0.389 2 0.0099 0.1944 main::BEGIN
+# 0.80 0.020 0.359 12 0.0017 0.0299 CPANPLUS::Backend::BEGIN
+# 0.40 0.010 0.010 30 0.0003 0.0003 Config::FETCH
+# 0.40 0.010 0.010 18 0.0006 0.0005 Locale::Maketext::Simple::load_loc
+#
+
+sub _search_module_tree {
+
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($mods,$list,$verbose,$type);
+ my $tmpl = {
+ data => { default => [],
+ strict_type=> 1, store => \$mods },
+ allow => { required => 1, default => [ ], strict_type => 1,
+ store => \$list },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ type => { required => 1, allow => [CPANPLUS::Module->accessors()],
+ store => \$type },
+ };
+
+ my $args = do {
+ ### don't check the template for sanity
+ ### -- we know it's good and saves a lot of performance
+ local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
+
+ check( $tmpl, \%hash );
+ } or return;
+
+ ### a list of module objects was supplied
+ if( @$mods ) {
+ local $Params::Check::VERBOSE = 0;
+
+ my @rv;
+ for my $mod (@$mods) {
+ #push @rv, $mod if check(
+ # { $type => { allow => $list } },
+ # { $type => $mod->$type() }
+ # );
+ push @rv, $mod if allow( $mod->$type() => $list );
+
+ }
+ return \@rv;
+
+ } else {
+ my @rv = $self->_source_search_module_tree(
+ allow => $list,
+ type => $type,
+ );
+ return \@rv;
+ }
+}
+
+=pod
+
+=head2 _search_author_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] )
+
+Searches the authortree for author objects matching the criteria you
+specify. Returns an array ref of author objects on success, and false
+on failure.
+
+It takes the following arguments:
+
+=over 4
+
+=item type
+
+This can be any of the accessors for the C<CPANPLUS::Module::Author>
+objects. This is a required argument.
+
+=item allow
+
+
+A set of rules, or more precisely, a list of regexes (via C<qr//> or
+plain strings), that the C<type> must adhere too. You can specify as
+many as you like, and it will be treated as an C<OR> search.
+For an C<AND> search, see the C<data> argument.
+
+This is a required argument.
+
+=item data
+
+An arrayref of previous search results. This is the way to do an C<and>
+search -- C<_search_author_tree> will only search the author objects
+specified in C<data> if provided, rather than the authortree itself.
+
+=back
+
+=cut
+
+sub _search_author_tree {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($authors,$list,$verbose,$type);
+ my $tmpl = {
+ data => { default => [],
+ strict_type=> 1, store => \$authors },
+ allow => { required => 1, default => [ ], strict_type => 1,
+ store => \$list },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ type => { required => 1, allow => [CPANPLUS::Module::Author->accessors()],
+ store => \$type },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ if( @$authors ) {
+ local $Params::Check::VERBOSE = 0;
+
+ my @rv;
+ for my $auth (@$authors) {
+ #push @rv, $auth if check(
+ # { $type => { allow => $list } },
+ # { $type => $auth->$type }
+ # );
+ push @rv, $auth if allow( $auth->$type() => $list );
+ }
+ return \@rv;
+ } else {
+ my @rv = $self->_source_search_author_tree(
+ allow => $list,
+ type => $type,
+ );
+ return \@rv;
+ }
+}
+
+=pod
+
+=head2 _all_installed()
+
+This function returns an array ref of module objects of modules that
+are installed on this system.
+
+=cut
+
+sub _all_installed {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ ### File::Find uses follow_skip => 1 by default, which doesn't die
+ ### on duplicates, unless they are directories or symlinks.
+ ### Ticket #29796 shows this code dying on Alien::WxWidgets,
+ ### which uses symlinks.
+ ### File::Find doc says to use follow_skip => 2 to ignore duplicates
+ ### so this will stop it from dying.
+ my %find_args = ( follow_skip => 2 );
+
+ ### File::Find uses lstat, which quietly becomes stat on win32
+ ### it then uses -l _ which is not allowed by the statbuffer because
+ ### you did a stat, not an lstat (duh!). so don't tell win32 to
+ ### follow symlinks, as that will break badly
+ $find_args{'follow_fast'} = 1 unless ON_WIN32;
+
+ ### never use the @INC hooks to find installed versions of
+ ### modules -- they're just there in case they're not on the
+ ### perl install, but the user shouldn't trust them for *other*
+ ### modules!
+ ### XXX CPANPLUS::inc is now obsolete, remove the calls
+ #local @INC = CPANPLUS::inc->original_inc;
+
+ my %seen; my @rv;
+ for my $dir (@INC ) {
+ next if $dir eq '.';
+
+ ### not a directory after all
+ ### may be coderef or some such
+ next unless -d $dir;
+
+ ### make sure to clean up the directories just in case,
+ ### as we're making assumptions about the length
+ ### This solves rt.cpan issue #19738
+
+ ### John M. notes: On VMS cannonpath can not currently handle
+ ### the $dir values that are in UNIX format.
+ $dir = File::Spec->canonpath( $dir ) unless ON_VMS;
+
+ ### have to use F::S::Unix on VMS, or things will break
+ my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec';
+
+ ### XXX in some cases File::Find can actually die!
+ ### so be safe and wrap it in an eval.
+ eval { File::Find::find(
+ { %find_args,
+ wanted => sub {
+
+ return unless /\.pm$/i;
+ my $mod = $File::Find::name;
+
+ ### make sure it's in Unix format, as it
+ ### may be in VMS format on VMS;
+ $mod = VMS::Filespec::unixify( $mod ) if ON_VMS;
+
+ $mod = substr($mod, length($dir) + 1, -3);
+ $mod = join '::', $file_spec->splitdir($mod);
+
+ return if $seen{$mod}++;
+
+ my $modobj = $self->module_tree($mod);
+
+ ### seperate return, a list context return with one ''
+ ### in it, is also true!
+ return unless $modobj;
+
+ push @rv, $modobj;
+ },
+ }, $dir
+ ) };
+
+ ### report the error if file::find died
+ error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@;
+ }
+
+ return \@rv;
+}
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm
new file mode 100644
index 00000000000..54e9d710cfd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source.pm
@@ -0,0 +1,1417 @@
+package CPANPLUS::Internals::Source;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Module;
+use CPANPLUS::Module::Fake;
+use CPANPLUS::Module::Author;
+use CPANPLUS::Internals::Constants;
+
+use File::Fetch;
+use Archive::Extract;
+
+use IPC::Cmd qw[can_run];
+use File::Temp qw[tempdir];
+use File::Basename qw[dirname];
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+$Params::Check::VERBOSE = 1;
+
+### list of methods the parent class must implement
+{ for my $sub ( qw[_init_trees _finalize_trees
+ _standard_trees_completed _custom_trees_completed
+ _add_module_object _add_author_object _save_state
+ ]
+ ) {
+ no strict 'refs';
+ *$sub = sub {
+ my $self = shift;
+ my $class = ref $self || $self;
+
+ require Carp;
+ Carp::croak( loc( "Class %1 must implement method '%2'",
+ $class, $sub ) );
+ }
+ }
+}
+
+{
+ my $recurse; # flag to prevent recursive calls to *_tree functions
+
+ ### lazy loading of module tree
+ sub _module_tree {
+ my $self = $_[0];
+
+ unless ($self->_mtree or $recurse++ > 0) {
+ my $uptodate = $self->_check_trees( @_[1..$#_] );
+ $self->_build_trees(uptodate => $uptodate);
+ }
+
+ $recurse--;
+ return $self->_mtree;
+ }
+
+ ### lazy loading of author tree
+ sub _author_tree {
+ my $self = $_[0];
+
+ unless ($self->_atree or $recurse++ > 0) {
+ my $uptodate = $self->_check_trees( @_[1..$#_] );
+ $self->_build_trees(uptodate => $uptodate);
+ }
+
+ $recurse--;
+ return $self->_atree;
+ }
+
+}
+
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Internals::Source
+
+=head1 SYNOPSIS
+
+ ### lazy load author/module trees ###
+
+ $cb->_author_tree;
+ $cb->_module_tree;
+
+=head1 DESCRIPTION
+
+CPANPLUS::Internals::Source controls the updating of source files and
+the parsing of them into usable module/author trees to be used by
+C<CPANPLUS>.
+
+Functions exist to check if source files are still C<good to use> as
+well as update them, and then parse them.
+
+The flow looks like this:
+
+ $cb->_author_tree || $cb->_module_tree
+ $cb->_check_trees
+ $cb->__check_uptodate
+ $cb->_update_source
+ $cb->__update_custom_module_sources
+ $cb->__update_custom_module_source
+ $cb->_build_trees
+ ### engine methods
+ { $cb->_init_trees;
+ $cb->_standard_trees_completed
+ $cb->_custom_trees_completed
+ }
+ $cb->__create_author_tree
+ ### engine methods
+ { $cb->_add_author_object }
+ $cb->__create_module_tree
+ $cb->__create_dslip_tree
+ ### engine methods
+ { $cb->_add_module_object }
+ $cb->__create_custom_module_entries
+
+ $cb->_dslip_defs
+
+=head1 METHODS
+
+=cut
+
+=pod
+
+=head2 $cb->_build_trees( uptodate => BOOL, [use_stored => BOOL, path => $path, verbose => BOOL] )
+
+This method rebuilds the author- and module-trees from source.
+
+It takes the following arguments:
+
+=over 4
+
+=item uptodate
+
+Indicates whether any on disk caches are still ok to use.
+
+=item path
+
+The absolute path to the directory holding the source files.
+
+=item verbose
+
+A boolean flag indicating whether or not to be verbose.
+
+=item use_stored
+
+A boolean flag indicating whether or not it is ok to use previously
+stored trees. Defaults to true.
+
+=back
+
+Returns a boolean indicating success.
+
+=cut
+
+### (re)build the trees ###
+sub _build_trees {
+ my ($self, %hash) = @_;
+ my $conf = $self->configure_object;
+
+ my($path,$uptodate,$use_stored,$verbose);
+ my $tmpl = {
+ path => { default => $conf->get_conf('base'), store => \$path },
+ verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+ uptodate => { required => 1, store => \$uptodate },
+ use_stored => { default => 1, store => \$use_stored },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ $self->_init_trees(
+ path => $path,
+ uptodate => $uptodate,
+ verbose => $verbose,
+ use_stored => $use_stored,
+ ) or do {
+ error( loc("Could not initialize trees" ) );
+ return;
+ };
+
+ ### return if we weren't able to build the trees ###
+ return unless $self->_mtree && $self->_atree;
+
+ ### did we get everything from a stored state? if not,
+ ### process them now.
+ if( not $self->_standard_trees_completed ) {
+
+ ### first, prep the author tree
+ $self->__create_author_tree(
+ uptodate => $uptodate,
+ path => $path,
+ verbose => $verbose,
+ ) or return;
+
+ ### and now the module tree
+ $self->_create_mod_tree(
+ uptodate => $uptodate,
+ path => $path,
+ verbose => $verbose,
+ ) or return;
+ }
+
+ ### XXX unpleasant hack. since custom sources uses ->parse_module, we
+ ### already have a special module object with extra meta data. that
+ ### doesn't gelwell with the sqlite storage engine. So, we check 'normal'
+ ### trees from seperate trees, so the engine can treat them differently.
+ ### Effectively this means that with the SQLite engine, for now, custom
+ ### sources are continuously reparsed =/ -kane
+ if( not $self->_custom_trees_completed ) {
+
+ ### update them if the other sources are also deemed out of date
+ if( $conf->get_conf('enable_custom_sources') ) {
+ $self->__update_custom_module_sources( verbose => $verbose )
+ or error(loc("Could not update custom module sources"));
+ }
+
+ ### add custom sources here if enabled
+ if( $conf->get_conf('enable_custom_sources') ) {
+ $self->__create_custom_module_entries( verbose => $verbose )
+ or error(loc("Could not create custom module entries"));
+ }
+ }
+
+ ### give the source engine a chance to wrap up creation
+ $self->_finalize_trees(
+ path => $path,
+ uptodate => $uptodate,
+ verbose => $verbose,
+ use_stored => $use_stored,
+ ) or do {
+ error(loc( "Could not finalize trees" ));
+ return;
+ };
+
+ ### still necessary? can only run one instance now ###
+ ### will probably stay that way --kane
+# my $id = $self->_store_id( $self );
+#
+# unless ( $id == $self->_id ) {
+# error( loc("IDs do not match: %1 != %2. Storage failed!", $id, $self->_id) );
+# }
+
+ return 1;
+}
+
+=pod
+
+=head2 $cb->_check_trees( [update_source => BOOL, path => PATH, verbose => BOOL] )
+
+Retrieve source files and return a boolean indicating whether or not
+the source files are up to date.
+
+Takes several arguments:
+
+=over 4
+
+=item update_source
+
+A flag to force re-fetching of the source files, even
+if they are still up to date.
+
+=item path
+
+The absolute path to the directory holding the source files.
+
+=item verbose
+
+A boolean flag indicating whether or not to be verbose.
+
+=back
+
+Will get information from the config file by default.
+
+=cut
+
+### retrieve source files, and returns a boolean indicating if it's up to date
+sub _check_trees {
+ my ($self, %hash) = @_;
+ my $conf = $self->configure_object;
+
+ my $update_source;
+ my $verbose;
+ my $path;
+
+ my $tmpl = {
+ path => { default => $conf->get_conf('base'),
+ store => \$path
+ },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose
+ },
+ update_source => { default => 0, store => \$update_source },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ ### if the user never wants to update their source without explicitly
+ ### telling us, shortcircuit here
+ return 1 if $conf->get_conf('no_update') && !$update_source;
+
+ ### a check to see if our source files are still up to date ###
+ msg( loc("Checking if source files are up to date"), $verbose );
+
+ my $uptodate = 1; # default return value
+
+ for my $name (qw[auth dslip mod]) {
+ for my $file ( $conf->_get_source( $name ) ) {
+ $self->__check_uptodate(
+ file => File::Spec->catfile( $path, $file ),
+ name => $name,
+ update_source => $update_source,
+ verbose => $verbose,
+ ) or $uptodate = 0;
+ }
+ }
+
+ ### if we're explicitly asked to update the sources, or if the
+ ### standard source files are out of date, update the custom sources
+ ### as well
+ ### RT #47820: Don't try to update custom sources if they are disabled
+ ### in the configuration.
+ $self->__update_custom_module_sources( verbose => $verbose )
+ if $conf->get_conf('enable_custom_sources') and ( $update_source or !$uptodate );
+
+ return $uptodate;
+}
+
+=pod
+
+=head2 $cb->__check_uptodate( file => $file, name => $name, [update_source => BOOL, verbose => BOOL] )
+
+C<__check_uptodate> checks if a given source file is still up-to-date
+and if not, or when C<update_source> is true, will re-fetch the source
+file.
+
+Takes the following arguments:
+
+=over 4
+
+=item file
+
+The source file to check.
+
+=item name
+
+The internal shortcut name for the source file (used for config
+lookups).
+
+=item update_source
+
+Flag to force updating of sourcefiles regardless.
+
+=item verbose
+
+Boolean to indicate whether to be verbose or not.
+
+=back
+
+Returns a boolean value indicating whether the current files are up
+to date or not.
+
+=cut
+
+### this method checks whether or not the source files we are using are still up to date
+sub __check_uptodate {
+ my $self = shift;
+ my %hash = @_;
+ my $conf = $self->configure_object;
+
+
+ my $tmpl = {
+ file => { required => 1 },
+ name => { required => 1 },
+ update_source => { default => 0 },
+ verbose => { default => $conf->get_conf('verbose') },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ my $flag;
+ unless ( -e $args->{'file'} && (
+ ( stat $args->{'file'} )[9]
+ + $conf->_get_source('update') )
+ > time ) {
+ $flag = 1;
+ }
+
+ if ( $flag or $args->{'update_source'} ) {
+
+ if ( $self->_update_source( name => $args->{'name'} ) ) {
+ return 0; # return 0 so 'uptodate' will be set to 0, meaning no
+ # use of previously stored hashrefs!
+ } else {
+ msg( loc("Unable to update source, attempting to get away with using old source file!"), $args->{verbose} );
+ return 1;
+ }
+
+ } else {
+ return 1;
+ }
+}
+
+=pod
+
+=head2 $cb->_update_source( name => $name, [path => $path, verbose => BOOL] )
+
+This method does the actual fetching of source files.
+
+It takes the following arguments:
+
+=over 4
+
+=item name
+
+The internal shortcut name for the source file (used for config
+lookups).
+
+=item path
+
+The full path where to write the files.
+
+=item verbose
+
+Boolean to indicate whether to be verbose or not.
+
+=back
+
+Returns a boolean to indicate success.
+
+=cut
+
+### this sub fetches new source files ###
+sub _update_source {
+ my $self = shift;
+ my %hash = @_;
+ my $conf = $self->configure_object;
+
+ my $verbose;
+ my $tmpl = {
+ name => { required => 1 },
+ path => { default => $conf->get_conf('base') },
+ verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+
+ my $path = $args->{path};
+ { ### this could use a clean up - Kane
+ ### no worries about the / -> we get it from the _ftp configuration, so
+ ### it's not platform dependant. -kane
+ my ($dir, $file) = $conf->_get_mirror( $args->{'name'} ) =~ m|(.+/)(.+)$|sg;
+
+ msg( loc("Updating source file '%1'", $file), $verbose );
+
+ my $fake = CPANPLUS::Module::Fake->new(
+ module => $args->{'name'},
+ path => $dir,
+ package => $file,
+ _id => $self->_id,
+ );
+
+ ### can't use $fake->fetch here, since ->parent won't work --
+ ### the sources haven't been saved yet
+ my $rv = $self->_fetch(
+ module => $fake,
+ fetchdir => $path,
+ force => 1,
+ );
+
+
+ unless ($rv) {
+ error( loc("Couldn't fetch '%1'", $file) );
+ return;
+ }
+
+ $self->_update_timestamp( file => File::Spec->catfile($path, $file) );
+ }
+
+ return 1;
+}
+
+=pod
+
+=head2 $cb->__create_author_tree([path => $path, uptodate => BOOL, verbose => BOOL])
+
+This method opens a source files and parses its contents into a
+searchable author-tree or restores a file-cached version of a
+previous parse, if the sources are uptodate and the file-cache exists.
+
+It takes the following arguments:
+
+=over 4
+
+=item uptodate
+
+A flag indicating whether the file-cache is uptodate or not.
+
+=item path
+
+The absolute path to the directory holding the source files.
+
+=item verbose
+
+A boolean flag indicating whether or not to be verbose.
+
+=back
+
+Will get information from the config file by default.
+
+Returns a tree on success, false on failure.
+
+=cut
+
+sub __create_author_tree {
+ my $self = shift;
+ my %hash = @_;
+ my $conf = $self->configure_object;
+
+
+ my $tmpl = {
+ path => { default => $conf->get_conf('base') },
+ verbose => { default => $conf->get_conf('verbose') },
+ uptodate => { default => 0 },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ my $file = File::Spec->catfile(
+ $args->{path},
+ $conf->_get_source('auth')
+ );
+
+ msg(loc("Rebuilding author tree, this might take a while"),
+ $args->{verbose});
+
+ ### extract the file ###
+ my $ae = Archive::Extract->new( archive => $file ) or return;
+ my $out = STRIP_GZ_SUFFIX->($file);
+
+ ### make sure to set the PREFER_BIN flag if desired ###
+ { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
+ $ae->extract( to => $out ) or return;
+ }
+
+ my $cont = $self->_get_file_contents( file => $out ) or return;
+
+ ### don't need it anymore ###
+ unlink $out;
+
+ for ( split /\n/, $cont ) {
+ my($id, $name, $email) = m/^alias \s+
+ (\S+) \s+
+ "\s* ([^\"\<]+?) \s* <(.+)> \s*"
+ /x;
+
+ $self->_add_author_object(
+ author => $name, #authors name
+ email => $email, #authors email address
+ cpanid => $id, #authors CPAN ID
+ ) or error( loc("Could not add author '%1'", $name ) );
+
+ }
+
+ return $self->_atree;
+
+} #__create_author_tree
+
+=pod
+
+=head2 $cb->_create_mod_tree([path => $path, uptodate => BOOL, verbose => BOOL])
+
+This method opens a source files and parses its contents into a
+searchable module-tree or restores a file-cached version of a
+previous parse, if the sources are uptodate and the file-cache exists.
+
+It takes the following arguments:
+
+=over 4
+
+=item uptodate
+
+A flag indicating whether the file-cache is up-to-date or not.
+
+=item path
+
+The absolute path to the directory holding the source files.
+
+=item verbose
+
+A boolean flag indicating whether or not to be verbose.
+
+=back
+
+Will get information from the config file by default.
+
+Returns a tree on success, false on failure.
+
+=cut
+
+### this builds a hash reference with the structure of the cpan module tree ###
+sub _create_mod_tree {
+ my $self = shift;
+ my %hash = @_;
+ my $conf = $self->configure_object;
+
+
+ my $tmpl = {
+ path => { default => $conf->get_conf('base') },
+ verbose => { default => $conf->get_conf('verbose') },
+ uptodate => { default => 0 },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return undef;
+ my $file = File::Spec->catfile($args->{path}, $conf->_get_source('mod'));
+
+ msg(loc("Rebuilding module tree, this might take a while"),
+ $args->{verbose});
+
+
+ my $dslip_tree = $self->__create_dslip_tree( %$args );
+
+ ### extract the file ###
+ my $ae = Archive::Extract->new( archive => $file ) or return;
+ my $out = STRIP_GZ_SUFFIX->($file);
+
+ ### make sure to set the PREFER_BIN flag if desired ###
+ { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
+ $ae->extract( to => $out ) or return;
+ }
+
+ my $content = $self->_get_file_contents( file => $out ) or return;
+ my $lines = $content =~ tr/\n/\n/;
+
+ ### don't need it anymore ###
+ unlink $out;
+
+ my($past_header, $count);
+ for ( split /\n/, $content ) {
+
+ ### quick hack to read past the header of the file ###
+ ### this is still rather evil... fix some time - Kane
+ if( m|^\s*$| ) {
+ unless( $count ) {
+ error(loc("Could not determine line count from %1", $file));
+ return;
+ }
+ $past_header = 1;
+ }
+
+ ### we're still in the header -- find the amount of lines we expect
+ unless( $past_header ) {
+
+ ### if the line count doesn't match what we expect, bail out
+ ### this should address: #45644: detect broken index
+ $count = $1 if /^Line-Count:\s+(\d+)/;
+ if( $count ) {
+ if( $lines < $count ) {
+ error(loc("Expected to read at least %1 lines, but %2 ".
+ "contains only %3 lines!",
+ $count, $file, $lines ));
+ return;
+ }
+ }
+ ### still in the header, keep moving
+ next;
+ }
+
+ ### skip empty lines ###
+ next unless /\S/;
+ chomp;
+
+ my @data = split /\s+/;
+
+ ### filter out the author and filename as well ###
+ ### authors can apparently have digits in their names,
+ ### and dirs can have dots... blah!
+ my ($author, $package) = $data[2] =~
+ m| (?:[A-Z\d-]/)?
+ (?:[A-Z\d-]{2}/)?
+ ([A-Z\d-]+) (?:/[\S]+)?/
+ ([^/]+)$
+ |xsg;
+
+ ### remove file name from the path
+ $data[2] =~ s|/[^/]+$||;
+
+ my $aobj = $self->author_tree($author);
+ unless( $aobj ) {
+ error( loc( "No such author '%1' -- can't make module object " .
+ "'%2' that is supposed to belong to this author",
+ $author, $data[0] ) );
+ next;
+ }
+
+ ### adding the dslip info
+ ### probably can use some optimization
+ my $dslip;
+ for my $item ( qw[ statd stats statl stati statp ] ) {
+ ### checking if there's an entry in the dslip info before
+ ### catting it on. appeasing warnings this way
+ $dslip .= $dslip_tree->{ $data[0] }->{$item}
+ ? $dslip_tree->{ $data[0] }->{$item}
+ : ' ';
+ }
+
+ ### XXX this could be sped up if we used author names, not author
+ ### objects in creation, and then look them up in the author tree
+ ### when needed. This will need a fix to all the places that create
+ ### fake author/module objects as well.
+
+ ### callback to store the individual object
+ $self->_add_module_object(
+ module => $data[0], # full module name
+ version => ($data[1] eq 'undef' # version number
+ ? '0.0'
+ : $data[1]),
+ path => File::Spec::Unix->catfile(
+ $conf->_get_mirror('base'),
+ $data[2],
+ ), # extended path on the cpan mirror,
+ # like /A/AB/ABIGAIL
+ comment => $data[3], # comment on the module
+ author => $aobj,
+ package => $package, # package name, like
+ # 'foo-bar-baz-1.03.tar.gz'
+ description => $dslip_tree->{ $data[0] }->{'description'},
+ dslip => $dslip,
+ mtime => '',
+ ) or error( loc( "Could not add module '%1'", $data[0] ) );
+
+ } #for
+
+ return $self->_mtree;
+
+} #_create_mod_tree
+
+=pod
+
+=head2 $cb->__create_dslip_tree([path => $path, uptodate => BOOL, verbose => BOOL])
+
+This method opens a source files and parses its contents into a
+searchable dslip-tree or restores a file-cached version of a
+previous parse, if the sources are uptodate and the file-cache exists.
+
+It takes the following arguments:
+
+=over 4
+
+=item uptodate
+
+A flag indicating whether the file-cache is uptodate or not.
+
+=item path
+
+The absolute path to the directory holding the source files.
+
+=item verbose
+
+A boolean flag indicating whether or not to be verbose.
+
+=back
+
+Will get information from the config file by default.
+
+Returns a tree on success, false on failure.
+
+=cut
+
+sub __create_dslip_tree {
+ my $self = shift;
+ my %hash = @_;
+ my $conf = $self->configure_object;
+
+ my $tmpl = {
+ path => { default => $conf->get_conf('base') },
+ verbose => { default => $conf->get_conf('verbose') },
+ uptodate => { default => 0 },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ ### get the file name of the source ###
+ my $file = File::Spec->catfile($args->{path}, $conf->_get_source('dslip'));
+
+ ### extract the file ###
+ my $ae = Archive::Extract->new( archive => $file ) or return;
+ my $out = STRIP_GZ_SUFFIX->($file);
+
+ ### make sure to set the PREFER_BIN flag if desired ###
+ { local $Archive::Extract::PREFER_BIN = $conf->get_conf('prefer_bin');
+ $ae->extract( to => $out ) or return;
+ }
+
+ my $in = $self->_get_file_contents( file => $out ) or return;
+
+ ### don't need it anymore ###
+ unlink $out;
+
+
+ ### get rid of the comments and the code ###
+ ### need a smarter parser, some people have this in their dslip info:
+ # [
+ # 'Statistics::LTU',
+ # 'R',
+ # 'd',
+ # 'p',
+ # 'O',
+ # '?',
+ # 'Implements Linear Threshold Units',
+ # ...skipping...
+ # "\x{c4}dd \x{fc}ml\x{e4}\x{fc}ts t\x{f6} \x{eb}v\x{eb}r\x{ff}th\x{ef}ng!",
+ # 'BENNIE',
+ # '11'
+ # ],
+ ### also, older versions say:
+ ### $cols = [....]
+ ### and newer versions say:
+ ### $CPANPLUS::Modulelist::cols = [...]
+ ### split '$cols' and '$data' into 2 variables ###
+ ### use this regex to make sure dslips with ';' in them don't cause
+ ### parser errors
+ my ($ds_one, $ds_two) = ($in =~ m|.+}\s+
+ (\$(?:CPAN::Modulelist::)?cols.*?)
+ (\$(?:CPAN::Modulelist::)?data.*)
+ |sx);
+
+ ### eval them into existence ###
+ ### still not too fond of this solution - kane ###
+ my ($cols, $data);
+ { #local $@; can't use this, it's buggy -kane
+
+ $cols = eval $ds_one;
+ error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
+
+ $data = eval $ds_two;
+ error( loc("Error in eval of dslip source files: %1", $@) ) if $@;
+
+ }
+
+ my $tree = {};
+ my $primary = "modid";
+
+ ### this comes from CPAN::Modulelist
+ ### which is in 03modlist.data.gz
+ for (@$data){
+ my %hash;
+ @hash{@$cols} = @$_;
+ $tree->{$hash{$primary}} = \%hash;
+ }
+
+ return $tree;
+
+} #__create_dslip_tree
+
+=pod
+
+=head2 $cb->_dslip_defs ()
+
+This function returns the definition structure (ARRAYREF) of the
+dslip tree.
+
+=cut
+
+### these are the definitions used for dslip info
+### they shouldn't change over time.. so hardcoding them doesn't appear to
+### be a problem. if it is, we need to parse 03modlist.data better to filter
+### all this out.
+### right now, this is just used to look up dslip info from a module
+sub _dslip_defs {
+ my $self = shift;
+
+ my $aref = [
+
+ # D
+ [ q|Development Stage|, {
+ i => loc('Idea, listed to gain consensus or as a placeholder'),
+ c => loc('under construction but pre-alpha (not yet released)'),
+ a => loc('Alpha testing'),
+ b => loc('Beta testing'),
+ R => loc('Released'),
+ M => loc('Mature (no rigorous definition)'),
+ S => loc('Standard, supplied with Perl 5'),
+ }],
+
+ # S
+ [ q|Support Level|, {
+ m => loc('Mailing-list'),
+ d => loc('Developer'),
+ u => loc('Usenet newsgroup comp.lang.perl.modules'),
+ n => loc('None known, try comp.lang.perl.modules'),
+ a => loc('Abandoned; volunteers welcome to take over maintainance'),
+ }],
+
+ # L
+ [ q|Language Used|, {
+ p => loc('Perl-only, no compiler needed, should be platform independent'),
+ c => loc('C and perl, a C compiler will be needed'),
+ h => loc('Hybrid, written in perl with optional C code, no compiler needed'),
+ '+' => loc('C++ and perl, a C++ compiler will be needed'),
+ o => loc('perl and another language other than C or C++'),
+ }],
+
+ # I
+ [ q|Interface Style|, {
+ f => loc('plain Functions, no references used'),
+ h => loc('hybrid, object and function interfaces available'),
+ n => loc('no interface at all (huh?)'),
+ r => loc('some use of unblessed References or ties'),
+ O => loc('Object oriented using blessed references and/or inheritance'),
+ }],
+
+ # P
+ [ q|Public License|, {
+ p => loc('Standard-Perl: user may choose between GPL and Artistic'),
+ g => loc('GPL: GNU General Public License'),
+ l => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'),
+ b => loc('BSD: The BSD License'),
+ a => loc('Artistic license alone'),
+ o => loc('other (but distribution allowed without restrictions)'),
+ }],
+ ];
+
+ return $aref;
+}
+
+=head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] );
+
+Adds a custom source index and updates it based on the provided URI.
+
+Returns the full path to the index file on success or false on failure.
+
+=cut
+
+sub _add_custom_module_source {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($verbose,$uri);
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ uri => { required => 1, store => \$uri }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### what index file should we use on disk?
+ my $index = $self->__custom_module_source_index_file( uri => $uri );
+
+ ### already have it.
+ if( IS_FILE->( $index ) ) {
+ msg(loc("Source '%1' already added", $uri));
+ return 1;
+ }
+
+ ### do we need to create the targe dir?
+ { my $dir = dirname( $index );
+ unless( IS_DIR->( $dir ) ) {
+ $self->_mkdir( dir => $dir ) or return
+ }
+ }
+
+ ### write the file
+ my $fh = OPEN_FILE->( $index => '>' ) or do {
+ error(loc("Could not open index file for '%1'", $uri));
+ return;
+ };
+
+ ### basically we 'touched' it. Check the return value, may be
+ ### important on win32 and similar OS, where there's file length
+ ### limits
+ close $fh or do {
+ error(loc("Could not write index file to disk for '%1'", $uri));
+ return;
+ };
+
+ $self->__update_custom_module_source(
+ remote => $uri,
+ local => $index,
+ verbose => $verbose,
+ ) or do {
+ ### we faild to update it, we probably have an empty
+ ### possibly silly filename on disk now -- remove it
+ 1 while unlink $index;
+ return;
+ };
+
+ return $index;
+}
+
+=head2 $index = $cb->__custom_module_source_index_file( uri => $uri );
+
+Returns the full path to the encoded index file for C<$uri>, as used by
+all C<custom module source> routines.
+
+=cut
+
+sub __custom_module_source_index_file {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($verbose,$uri);
+ my $tmpl = {
+ uri => { required => 1, store => \$uri }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my $index = File::Spec->catfile(
+ $conf->get_conf('base'),
+ $conf->_get_build('custom_sources'),
+ $self->_uri_encode( uri => $uri ),
+ );
+
+ return $index;
+}
+
+=head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] );
+
+Removes a custom index file based on the URI provided.
+
+Returns the full path to the index file on success or false on failure.
+
+=cut
+
+sub _remove_custom_module_source {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($verbose,$uri);
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ uri => { required => 1, store => \$uri }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### use uri => local, instead of the other way around
+ my %files = reverse $self->__list_custom_module_sources;
+
+ ### On VMS the case of key to %files can be either exact or lower case
+ ### XXX abstract this lookup out? --kane
+ my $file = $files{ $uri };
+ $file = $files{ lc $uri } if !defined($file) && ON_VMS;
+
+ unless (defined $file) {
+ error(loc("No such custom source '%1'", $uri));
+ return;
+ };
+
+ 1 while unlink $file;
+
+ if( IS_FILE->( $file ) ) {
+ error(loc("Could not remove index file '%1' for custom source '%2'",
+ $file, $uri));
+ return;
+ }
+
+ msg(loc("Successfully removed index file for '%1'", $uri), $verbose);
+
+ return $file;
+}
+
+=head2 %files = $cb->__list_custom_module_sources
+
+This method scans the 'custom-sources' directory in your base directory
+for additional sources to include in your module tree.
+
+Returns a list of key value pairs as follows:
+
+ /full/path/to/source/file%3Fencoded => http://decoded/mirror/path
+
+=cut
+
+sub __list_custom_module_sources {
+ my $self = shift;
+ my $conf = $self->configure_object;
+
+ my($verbose);
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ };
+
+ my $dir = File::Spec->catdir(
+ $conf->get_conf('base'),
+ $conf->_get_build('custom_sources'),
+ );
+
+ unless( IS_DIR->( $dir ) ) {
+ msg(loc("No '%1' dir, skipping custom sources", $dir), $verbose);
+ return;
+ }
+
+ ### unencode the files
+ ### skip ones starting with # though
+ my %files = map {
+ my $org = $_;
+ my $dec = $self->_uri_decode( uri => $_ );
+ File::Spec->catfile( $dir, $org ) => $dec
+ } grep { $_ !~ /^#/ } READ_DIR->( $dir );
+
+ return %files;
+}
+
+=head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] );
+
+Attempts to update all the index files to your custom module sources.
+
+If the index is missing, and it's a C<file://> uri, it will generate
+a new local index for you.
+
+Return true on success, false on failure.
+
+=cut
+
+sub __update_custom_module_sources {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my $verbose;
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my %files = $self->__list_custom_module_sources;
+
+ ### uptodate check has been done a few levels up.
+ my $fail;
+ while( my($local,$remote) = each %files ) {
+
+ $self->__update_custom_module_source(
+ remote => $remote,
+ local => $local,
+ verbose => $verbose,
+ ) or ( $fail++, next );
+ }
+
+ error(loc("Failed updating one or more remote sources files")) if $fail;
+
+ return if $fail;
+ return 1;
+}
+
+=head2 $ok = $cb->__update_custom_module_source
+
+Attempts to update all the index files to your custom module sources.
+
+If the index is missing, and it's a C<file://> uri, it will generate
+a new local index for you.
+
+Return true on success, false on failure.
+
+=cut
+
+sub __update_custom_module_source {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($verbose,$local,$remote);
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ local => { store => \$local, allow => FILE_EXISTS },
+ remote => { required => 1, store => \$remote },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ msg( loc("Updating sources from '%1'", $remote), $verbose);
+
+ ### if you didn't provide a local file, we'll look in your custom
+ ### dir to find the local encoded version for you
+ $local ||= do {
+ ### find all files we know of
+ my %files = reverse $self->__list_custom_module_sources or do {
+ error(loc("No custom modules sources defined -- need '%1' argument",
+ 'local'));
+ return;
+ };
+
+ ### On VMS the case of key to %files can be either exact or lower case
+ ### XXX abstract this lookup out? --kane
+ my $file = $files{ $remote };
+ $file = $files{ lc $remote } if !defined ($file) && ON_VMS;
+
+ ### return the local file we're supposed to use
+ $file or do {
+ error(loc("Remote source '%1' unknown -- needs '%2' argument",
+ $remote, 'local'));
+ return;
+ };
+ };
+
+ my $uri = join '/', $remote, $conf->_get_source('custom_index');
+ my $ff = File::Fetch->new( uri => $uri );
+
+ ### tempdir doesn't clean up by default, as opposed to tempfile()
+ ### so add it explicitly.
+ my $dir = tempdir( CLEANUP => 1 );
+
+ my $res = do { local $File::Fetch::WARN = 0;
+ local $File::Fetch::WARN = 0;
+ $ff->fetch( to => $dir );
+ };
+
+ ### couldn't get the file
+ unless( $res ) {
+
+ ### it's not a local scheme, so can't auto index
+ unless( $ff->scheme eq 'file' ) {
+ error(loc("Could not update sources from '%1': %2",
+ $remote, $ff->error ));
+ return;
+
+ ### it's a local uri, we can index it ourselves
+ } else {
+ msg(loc("No index file found at '%1', generating one",
+ $ff->uri), $verbose );
+
+ ### ON VMS, if you are working with a UNIX file specification,
+ ### you need currently use the UNIX variants of the File::Spec.
+ my $ff_path = do {
+ my $file_class = 'File::Spec';
+ $file_class .= '::Unix' if ON_VMS;
+ $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) );
+ };
+
+ $self->__write_custom_module_index(
+ path => $ff_path,
+ to => $local,
+ verbose => $verbose,
+ ) or return;
+
+ ### XXX don't write that here, __write_custom_module_index
+ ### already prints this out
+ #msg(loc("Index file written to '%1'", $to), $verbose);
+ }
+
+ ### copy it to the real spot and update its timestamp
+ } else {
+ $self->_move( file => $res, to => $local ) or return;
+ $self->_update_timestamp( file => $local );
+
+ msg(loc("Index file saved to '%1'", $local), $verbose);
+ }
+
+ return $local;
+}
+
+=head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] )
+
+Scans the C<path> you provided for packages and writes an index with all
+the available packages to C<$path/packages.txt>. If you'd like the index
+to be written to a different file, provide the C<to> argument.
+
+Returns true on success and false on failure.
+
+=cut
+
+sub __write_custom_module_index {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my ($verbose, $path, $to);
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ path => { required => 1, allow => DIR_EXISTS, store => \$path },
+ to => { store => \$to },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### no explicit to? then we'll use our default
+ $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') );
+
+ my @files;
+ require File::Find;
+ File::Find::find( sub {
+ ### let's see if A::E can even parse it
+ my $ae = do {
+ local $Archive::Extract::WARN = 0;
+ local $Archive::Extract::WARN = 0;
+ Archive::Extract->new( archive => $File::Find::name )
+ } or return;
+
+ ### it's a type A::E recognize, so we can add it
+ $ae->type or return;
+
+ ### neither $_ nor $File::Find::name have the chunk of the path in
+ ### it starting $path -- it's either only the filename, or the full
+ ### path, so we have to strip it ourselves
+ ### make sure to remove the leading slash as well.
+ my $copy = $File::Find::name;
+ my $re = quotemeta($path);
+ $copy =~ s|^$re[\\/]?||i;
+
+ push @files, $copy;
+
+ }, $path );
+
+ ### does the dir exist? if not, create it.
+ { my $dir = dirname( $to );
+ unless( IS_DIR->( $dir ) ) {
+ $self->_mkdir( dir => $dir ) or return
+ }
+ }
+
+ ### create the index file
+ my $fh = OPEN_FILE->( $to => '>' ) or return;
+
+ print $fh "$_\n" for @files;
+ close $fh;
+
+ msg(loc("Successfully written index file to '%1'", $to), $verbose);
+
+ return $to;
+}
+
+
+=head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] )
+
+Creates entries in the module tree based upon the files as returned
+by C<__list_custom_module_sources>.
+
+Returns true on success, false on failure.
+
+=cut
+
+### use $auth_obj as a persistant version, so we don't have to recreate
+### modules all the time
+{ my $auth_obj;
+
+ sub __create_custom_module_entries {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my $verbose;
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+ };
+
+ check( $tmpl, \%hash ) or return undef;
+
+ my %files = $self->__list_custom_module_sources;
+
+ while( my($file,$name) = each %files ) {
+
+ msg(loc("Adding packages from custom source '%1'", $name), $verbose);
+
+ my $fh = OPEN_FILE->( $file ) or next;
+
+ while( local $_ = <$fh> ) {
+ chomp;
+ next if /^#/;
+ next unless /\S+/;
+
+ ### join on / -- it's a URI after all!
+ my $parse = join '/', $name, $_;
+
+ ### try to make a module object out of it
+ my $mod = $self->parse_module( module => $parse ) or (
+ error(loc("Could not parse '%1'", $_)),
+ next
+ );
+
+ ### mark this object with a custom author
+ $auth_obj ||= do {
+ my $id = CUSTOM_AUTHOR_ID;
+
+ ### if the object is being created for the first time,
+ ### make sure there's an entry in the author tree as
+ ### well, so we can search on the CPAN ID
+ $self->author_tree->{ $id } =
+ CPANPLUS::Module::Author::Fake->new( cpanid => $id );
+ };
+
+ $mod->author( $auth_obj );
+
+ ### and now add it to the modlue tree -- this MAY
+ ### override things of course
+ if( my $old_mod = $self->module_tree( $mod->module ) ) {
+
+ ### On VMS use the old module name to get the real case
+ $mod->module( $old_mod->module ) if ON_VMS;
+
+ msg(loc("About to overwrite module tree entry for '%1' with '%2'",
+ $mod->module, $mod->package), $verbose);
+ }
+
+ ### mark where it came from
+ $mod->description( loc("Custom source from '%1'",$name) );
+
+ ### store it in the module tree
+ $self->module_tree->{ $mod->module } = $mod;
+ }
+ }
+
+ return 1;
+ }
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm
new file mode 100644
index 00000000000..cb3fd4f1e76
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/Memory.pm
@@ -0,0 +1,374 @@
+package CPANPLUS::Internals::Source::Memory;
+
+use base 'CPANPLUS::Internals::Source';
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Module;
+use CPANPLUS::Module::Fake;
+use CPANPLUS::Module::Author;
+use CPANPLUS::Internals::Constants;
+
+use File::Fetch;
+use Archive::Extract;
+
+use IPC::Cmd qw[can_run];
+use File::Temp qw[tempdir];
+use File::Basename qw[dirname];
+use Params::Check qw[allow check];
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+$Params::Check::VERBOSE = 1;
+
+=head1 NAME
+
+CPANPLUS::Internals::Source::Memory - In memory implementation
+
+=cut
+
+### flag to show if init_trees got its' data from storable. This allows
+### us to not write an existing stored file back to disk
+{ my $from_storable;
+
+ sub _init_trees {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($path,$uptodate,$verbose,$use_stored);
+ my $tmpl = {
+ path => { default => $conf->get_conf('base'), store => \$path },
+ verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+ uptodate => { required => 1, store => \$uptodate },
+ use_stored => { default => 1, store => \$use_stored },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### retrieve the stored source files ###
+ my $stored = $self->__memory_retrieve_source(
+ path => $path,
+ uptodate => $uptodate && $use_stored,
+ verbose => $verbose,
+ ) || {};
+
+ ### we got this from storable if $stored has keys..
+ $from_storable = keys %$stored ? 1 : 0;
+
+ ### set up the trees
+ $self->_atree( $stored->{_atree} || {} );
+ $self->_mtree( $stored->{_mtree} || {} );
+
+ return 1;
+ }
+
+ sub _standard_trees_completed { return $from_storable }
+ sub _custom_trees_completed { return $from_storable }
+
+ sub _finalize_trees {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($path,$uptodate,$verbose);
+ my $tmpl = {
+ path => { default => $conf->get_conf('base'), store => \$path },
+ verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+ uptodate => { required => 1, store => \$uptodate },
+ };
+
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+ check( $tmpl, \%hash ) or return;
+ }
+
+ ### write the stored files to disk, so we can keep using them
+ ### from now on, till they become invalid
+ ### write them if the original sources weren't uptodate, or
+ ### we didn't just load storable files
+ $self->__memory_save_source() if !$uptodate or not $from_storable;
+
+ return 1;
+ }
+
+ ### saves current memory state
+ sub _save_state {
+ my $self = shift;
+ return $self->_finalize_trees( @_, uptodate => 0 );
+ }
+}
+
+sub _add_author_object {
+ my $self = shift;
+ my %hash = @_;
+
+ my $class;
+ my $tmpl = {
+ class => { default => 'CPANPLUS::Module::Author', store => \$class },
+ map { $_ => { required => 1 } }
+ qw[ author cpanid email ]
+ };
+
+ my $href = do {
+ local $Params::Check::NO_DUPLICATES = 1;
+ check( $tmpl, \%hash ) or return;
+ };
+
+ my $obj = $class->new( %$href, _id => $self->_id );
+
+ $self->author_tree->{ $href->{'cpanid'} } = $obj or return;
+
+ return $obj;
+}
+
+sub _add_module_object {
+ my $self = shift;
+ my %hash = @_;
+
+ my $class;
+ my $tmpl = {
+ class => { default => 'CPANPLUS::Module', store => \$class },
+ map { $_ => { required => 1 } }
+ qw[ module version path comment author package description dslip mtime ]
+ };
+
+ my $href = do {
+ local $Params::Check::NO_DUPLICATES = 1;
+ check( $tmpl, \%hash ) or return;
+ };
+
+ my $obj = $class->new( %$href, _id => $self->_id );
+
+ ### Every module get's stored as a module object ###
+ $self->module_tree->{ $href->{module} } = $obj or return;
+
+ return $obj;
+}
+
+{ my %map = (
+ _source_search_module_tree => [ module_tree => 'CPANPLUS::Module' ],
+ _source_search_author_tree => [ author_tree => 'CPANPLUS::Module::Author' ],
+ );
+
+ while( my($sub, $aref) = each %map ) {
+ no strict 'refs';
+
+ my($meth, $class) = @$aref;
+
+ *$sub = sub {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($authors,$list,$verbose,$type);
+ my $tmpl = {
+ data => { default => [],
+ strict_type=> 1, store => \$authors },
+ allow => { required => 1, default => [ ], strict_type => 1,
+ store => \$list },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ type => { required => 1, allow => [$class->accessors()],
+ store => \$type },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ my @rv;
+ for my $obj ( values %{ $self->$meth } ) {
+ #push @rv, $auth if check(
+ # { $type => { allow => $list } },
+ # { $type => $auth->$type }
+ # );
+ push @rv, $obj if allow( $obj->$type() => $list );
+ }
+
+ return @rv;
+ }
+ }
+}
+
+=pod
+
+=head2 $cb->__memory_retrieve_source(name => $name, [path => $path, uptodate => BOOL, verbose => BOOL])
+
+This method retrieves a I<storable>d tree identified by C<$name>.
+
+It takes the following arguments:
+
+=over 4
+
+=item name
+
+The internal name for the source file to retrieve.
+
+=item uptodate
+
+A flag indicating whether the file-cache is up-to-date or not.
+
+=item path
+
+The absolute path to the directory holding the source files.
+
+=item verbose
+
+A boolean flag indicating whether or not to be verbose.
+
+=back
+
+Will get information from the config file by default.
+
+Returns a tree on success, false on failure.
+
+=cut
+
+sub __memory_retrieve_source {
+ my $self = shift;
+ my %hash = @_;
+ my $conf = $self->configure_object;
+
+ my $tmpl = {
+ path => { default => $conf->get_conf('base') },
+ verbose => { default => $conf->get_conf('verbose') },
+ uptodate => { default => 0 },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ ### check if we can retrieve a frozen data structure with storable ###
+ my $storable = can_load( modules => {'Storable' => '0.0'} )
+ if $conf->get_conf('storable');
+
+ return unless $storable;
+
+ ### $stored is the name of the frozen data structure ###
+ my $stored = $self->__memory_storable_file( $args->{path} );
+
+ if ($storable && -e $stored && -s _ && $args->{'uptodate'}) {
+ msg( loc("Retrieving %1", $stored), $args->{'verbose'} );
+
+ my $href = Storable::retrieve($stored);
+ return $href;
+ } else {
+ return;
+ }
+}
+
+=pod
+
+=head2 $cb->__memory_save_source([verbose => BOOL, path => $path])
+
+This method saves all the parsed trees in I<storable>d format if
+C<Storable> is available.
+
+It takes the following arguments:
+
+=over 4
+
+=item path
+
+The absolute path to the directory holding the source files.
+
+=item verbose
+
+A boolean flag indicating whether or not to be verbose.
+
+=back
+
+Will get information from the config file by default.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub __memory_save_source {
+ my $self = shift;
+ my %hash = @_;
+ my $conf = $self->configure_object;
+
+
+ my $tmpl = {
+ path => { default => $conf->get_conf('base'), allow => DIR_EXISTS },
+ verbose => { default => $conf->get_conf('verbose') },
+ force => { default => 1 },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ my $aref = [qw[_mtree _atree]];
+
+ ### check if we can retrieve a frozen data structure with storable ###
+ my $storable;
+ $storable = can_load( modules => {'Storable' => '0.0'} )
+ if $conf->get_conf('storable');
+ return unless $storable;
+
+ my $to_write = {};
+ foreach my $key ( @$aref ) {
+ next unless ref( $self->$key );
+ $to_write->{$key} = $self->$key;
+ }
+
+ return unless keys %$to_write;
+
+ ### $stored is the name of the frozen data structure ###
+ my $stored = $self->__memory_storable_file( $args->{path} );
+
+ if (-e $stored && not -w $stored) {
+ msg( loc("%1 not writable; skipped.", $stored), $args->{'verbose'} );
+ return;
+ }
+
+ msg( loc("Writing compiled source information to disk. This might take a little while."),
+ $args->{'verbose'} );
+
+ my $flag;
+ unless( Storable::nstore( $to_write, $stored ) ) {
+ error( loc("could not store %1!", $stored) );
+ $flag++;
+ }
+
+ return $flag ? 0 : 1;
+}
+
+sub __memory_storable_file {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my $path = shift or return;
+
+ ### check if we can retrieve a frozen data structure with storable ###
+ my $storable = $conf->get_conf('storable')
+ ? can_load( modules => {'Storable' => '0.0'} )
+ : 0;
+
+ return unless $storable;
+
+ ### $stored is the name of the frozen data structure ###
+ ### changed to use File::Spec->catfile -jmb
+ my $stored = File::Spec->rel2abs(
+ File::Spec->catfile(
+ $path, #base dir
+ $conf->_get_source('stored') #file
+ . '.s' .
+ $Storable::VERSION #the version of storable
+ . '.c' .
+ $self->VERSION #the version of CPANPLUS
+ . STORABLE_EXT #append a suffix
+ )
+ );
+
+ return $stored;
+}
+
+
+
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm
new file mode 100644
index 00000000000..a0ddf499bf6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite.pm
@@ -0,0 +1,326 @@
+package CPANPLUS::Internals::Source::SQLite;
+
+use strict;
+use warnings;
+
+use base 'CPANPLUS::Internals::Source';
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Internals::Source::SQLite::Tie;
+
+use Data::Dumper;
+use DBIx::Simple;
+use DBD::SQLite;
+
+use Params::Check qw[allow check];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+use constant TXN_COMMIT => 1000;
+
+=head1 NAME
+
+CPANPLUS::Internals::Source::SQLite - SQLite implementation
+
+=cut
+
+{ my $Dbh;
+ my $DbFile;
+
+ sub __sqlite_file {
+ return $DbFile if $DbFile;
+
+ my $self = shift;
+ my $conf = $self->configure_object;
+
+ $DbFile = File::Spec->catdir(
+ $conf->get_conf('base'),
+ SOURCE_SQLITE_DB
+ );
+
+ return $DbFile;
+ };
+
+ sub __sqlite_dbh {
+ return $Dbh if $Dbh;
+
+ my $self = shift;
+ $Dbh = DBIx::Simple->connect(
+ "dbi:SQLite:dbname=" . $self->__sqlite_file,
+ '', '',
+ { AutoCommit => 1 }
+ );
+ #$Dbh->dbh->trace(1);
+
+ return $Dbh;
+ };
+}
+
+{ my $used_old_copy = 0;
+
+ sub _init_trees {
+ my $self = shift;
+ my $conf = $self->configure_object;
+ my %hash = @_;
+
+ my($path,$uptodate,$verbose,$use_stored);
+ my $tmpl = {
+ path => { default => $conf->get_conf('base'), store => \$path },
+ verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+ uptodate => { required => 1, store => \$uptodate },
+ use_stored => { default => 1, store => \$use_stored },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### if it's not uptodate, or the file doesn't exist, we need to create
+ ### a new sqlite db
+ if( not $uptodate or not -e $self->__sqlite_file ) {
+ $used_old_copy = 0;
+
+ ### chuck the file
+ 1 while unlink $self->__sqlite_file;
+
+ ### and create a new one
+ $self->__sqlite_create_db or do {
+ error(loc("Could not create new SQLite DB"));
+ return;
+ }
+ } else {
+ $used_old_copy = 1;
+ }
+
+ ### set up the author tree
+ { my %at;
+ tie %at, 'CPANPLUS::Internals::Source::SQLite::Tie',
+ dbh => $self->__sqlite_dbh, table => 'author',
+ key => 'cpanid', cb => $self;
+
+ $self->_atree( \%at );
+ }
+
+ ### set up the author tree
+ { my %mt;
+ tie %mt, 'CPANPLUS::Internals::Source::SQLite::Tie',
+ dbh => $self->__sqlite_dbh, table => 'module',
+ key => 'module', cb => $self;
+
+ $self->_mtree( \%mt );
+ }
+
+ ### start a transaction
+ $self->__sqlite_dbh->query('BEGIN');
+
+ return 1;
+
+ }
+
+ sub _standard_trees_completed { return $used_old_copy }
+ sub _custom_trees_completed { return }
+ ### finish transaction
+ sub _finalize_trees { $_[0]->__sqlite_dbh->query('COMMIT'); return 1 }
+
+ ### saves current memory state, but not implemented in sqlite
+ sub _save_state {
+ error(loc("%1 has not implemented writing state to disk", __PACKAGE__));
+ return;
+ }
+}
+
+{ my $txn_count = 0;
+
+ ### XXX move this outside the sub, so we only compute it once
+ my $class;
+ my @keys = qw[ author cpanid email ];
+ my $tmpl = {
+ class => { default => 'CPANPLUS::Module::Author', store => \$class },
+ map { $_ => { required => 1 } } @keys
+ };
+
+ ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually
+ my $ph = join ',', map { '?' } @keys;
+
+
+ sub _add_author_object {
+ my $self = shift;
+ my %hash = @_;
+ my $dbh = $self->__sqlite_dbh;
+
+ my $href = do {
+ local $Params::Check::NO_DUPLICATES = 1;
+ local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
+ check( $tmpl, \%hash ) or return;
+ };
+
+ ### keep counting how many we inserted
+ unless( ++$txn_count % TXN_COMMIT ) {
+ #warn "Committing transaction $txn_count";
+ $dbh->query('COMMIT') or error( $dbh->error ); # commit previous transaction
+ $dbh->query('BEGIN') or error( $dbh->error ); # and start a new one
+ }
+
+ $dbh->query(
+ "INSERT INTO author (". join(',',keys(%$href)) .") VALUES ($ph)",
+ values %$href
+ ) or do {
+ error( $dbh->error );
+ return;
+ };
+
+ return 1;
+ }
+}
+
+{ my $txn_count = 0;
+
+ ### XXX move this outside the sub, so we only compute it once
+ my $class;
+ my @keys = qw[ module version path comment author package description dslip mtime ];
+ my $tmpl = {
+ class => { default => 'CPANPLUS::Module', store => \$class },
+ map { $_ => { required => 1 } } @keys
+ };
+
+ ### dbix::simple's expansion of (??) is REALLY expensive, so do it manually
+ my $ph = join ',', map { '?' } @keys;
+
+ sub _add_module_object {
+ my $self = shift;
+ my %hash = @_;
+ my $dbh = $self->__sqlite_dbh;
+
+ my $href = do {
+ local $Params::Check::NO_DUPLICATES = 1;
+ local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
+ check( $tmpl, \%hash ) or return;
+ };
+
+ ### fix up author to be 'plain' string
+ $href->{'author'} = $href->{'author'}->cpanid;
+
+ ### keep counting how many we inserted
+ unless( ++$txn_count % TXN_COMMIT ) {
+ #warn "Committing transaction $txn_count";
+ $dbh->query('COMMIT') or error( $dbh->error ); # commit previous transaction
+ $dbh->query('BEGIN') or error( $dbh->error ); # and start a new one
+ }
+
+ $dbh->query(
+ "INSERT INTO module (". join(',',keys(%$href)) .") VALUES ($ph)",
+ values %$href
+ ) or do {
+ error( $dbh->error );
+ return;
+ };
+
+ return 1;
+ }
+}
+
+{ my %map = (
+ _source_search_module_tree
+ => [ module => module => 'CPANPLUS::Module' ],
+ _source_search_author_tree
+ => [ author => cpanid => 'CPANPLUS::Module::Author' ],
+ );
+
+ while( my($sub, $aref) = each %map ) {
+ no strict 'refs';
+
+ my($table, $key, $class) = @$aref;
+ *$sub = sub {
+ my $self = shift;
+ my %hash = @_;
+ my $dbh = $self->__sqlite_dbh;
+
+ my($list,$type);
+ my $tmpl = {
+ allow => { required => 1, default => [ ], strict_type => 1,
+ store => \$list },
+ type => { required => 1, allow => [$class->accessors()],
+ store => \$type },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+
+ ### we aliased 'module' to 'name', so change that here too
+ $type = 'module' if $type eq 'name';
+
+ my $res = $dbh->query( "SELECT * from $table" );
+
+ my $meth = $table .'_tree';
+ my @rv = map { $self->$meth( $_->{$key} ) }
+ grep { allow( $_->{$type} => $list ) } $res->hashes;
+
+ return @rv;
+ }
+ }
+}
+
+
+
+sub __sqlite_create_db {
+ my $self = shift;
+ my $dbh = $self->__sqlite_dbh;
+
+ ### we can ignore the result/error; not all sqlite implemantation
+ ### support this
+ $dbh->query( qq[
+ DROP TABLE IF EXISTS author;
+ \n]
+ ) or do {
+ msg( $dbh->error );
+ };
+ $dbh->query( qq[
+ DROP TABLE IF EXISTS module;
+ \n]
+ ) or do {
+ msg( $dbh->error );
+ };
+
+
+
+ $dbh->query( qq[
+ /* the author information */
+ CREATE TABLE author (
+ id INTEGER PRIMARY KEY AUTOINCREMENT,
+
+ author varchar(255),
+ email varchar(255),
+ cpanid varchar(255)
+ );
+ \n]
+
+ ) or do {
+ error( $dbh->error );
+ return;
+ };
+
+ $dbh->query( qq[
+ /* the module information */
+ CREATE TABLE module (
+ id INTEGER PRIMARY KEY AUTOINCREMENT,
+
+ module varchar(255),
+ version varchar(255),
+ path varchar(255),
+ comment varchar(255),
+ author varchar(255),
+ package varchar(255),
+ description varchar(255),
+ dslip varchar(255),
+ mtime varchar(255)
+ );
+
+ \n]
+
+ ) or do {
+ error( $dbh->error );
+ return;
+ };
+
+ return 1;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm
new file mode 100644
index 00000000000..f908c9803e4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Source/SQLite/Tie.pm
@@ -0,0 +1,145 @@
+package CPANPLUS::Internals::Source::SQLite::Tie;
+
+use strict;
+use warnings;
+
+use CPANPLUS::Error;
+use CPANPLUS::Module;
+use CPANPLUS::Module::Fake;
+use CPANPLUS::Module::Author::Fake;
+use CPANPLUS::Internals::Constants;
+
+
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+
+use Data::Dumper;
+$Data::Dumper::Indent = 1;
+
+require Tie::Hash;
+use vars qw[@ISA];
+push @ISA, 'Tie::StdHash';
+
+
+sub TIEHASH {
+ my $class = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ dbh => { required => 1 },
+ table => { required => 1 },
+ key => { required => 1 },
+ cb => { required => 1 },
+ offset => { default => 0 },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+ my $obj = bless { %$args, store => {} } , $class;
+
+ return $obj;
+}
+
+sub FETCH {
+ my $self = shift;
+ my $key = shift or return;
+ my $dbh = $self->{dbh};
+ my $cb = $self->{cb};
+ my $table = $self->{table};
+
+
+ ### did we look this one up before?
+ if( my $obj = $self->{store}->{$key} ) {
+ return $obj;
+ }
+
+ my $res = $dbh->query(
+ "SELECT * from $table where $self->{key} = ?", $key
+ ) or do {
+ error( $dbh->error );
+ return;
+ };
+
+ my $href = $res->hash;
+
+ ### get rid of the primary key
+ delete $href->{'id'};
+
+ ### no results?
+ return unless keys %$href;
+
+ ### expand author if needed
+ ### XXX no longer generic :(
+ if( $table eq 'module' ) {
+ $href->{author} = $cb->author_tree( $href->{author } ) or return;
+ }
+
+ my $class = {
+ module => 'CPANPLUS::Module',
+ author => 'CPANPLUS::Module::Author',
+ }->{ $table };
+
+ my $obj = $self->{store}->{$key} = $class->new( %$href, _id => $cb->_id );
+
+ return $obj;
+}
+
+sub STORE {
+ my $self = shift;
+ my $key = shift;
+ my $val = shift;
+
+ $self->{store}->{$key} = $val;
+}
+
+1;
+
+sub FIRSTKEY {
+ my $self = shift;
+ my $dbh = $self->{'dbh'};
+
+ my $res = $dbh->query(
+ "select $self->{key} from $self->{table} order by $self->{key} limit 1"
+ );
+
+ $self->{offset} = 0;
+
+ my $key = $res->flat->[0];
+
+ return $key;
+}
+
+sub NEXTKEY {
+ my $self = shift;
+ my $dbh = $self->{'dbh'};
+
+ my $res = $dbh->query(
+ "select $self->{key} from $self->{table} ".
+ "order by $self->{key} limit 1 offset $self->{offset}"
+ );
+
+ $self->{offset} +=1;
+
+ my $key = $res->flat->[0];
+ my $val = $self->FETCH( $key );
+
+ ### use each() semantics
+ return wantarray ? ( $key, $val ) : $key;
+}
+
+sub EXISTS { !!$_[0]->FETCH( $_[1] ) }
+
+sub SCALAR {
+ my $self = shift;
+ my $dbh = $self->{'dbh'};
+
+ my $res = $dbh->query( "select count(*) from $self->{table}" );
+
+ return $res->flat;
+}
+
+### intentionally left blank
+sub DELETE { }
+sub CLEAR { }
+
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm
new file mode 100644
index 00000000000..27d2abcdad1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm
@@ -0,0 +1,657 @@
+package CPANPLUS::Internals::Utils;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use Cwd qw[chdir];
+use File::Copy;
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+local $Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Internals::Utils
+
+=head1 SYNOPSIS
+
+ my $bool = $cb->_mkdir( dir => 'blah' );
+ my $bool = $cb->_chdir( dir => 'blah' );
+ my $bool = $cb->_rmdir( dir => 'blah' );
+
+ my $bool = $cb->_move( from => '/some/file', to => '/other/file' );
+ my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' );
+
+ my $cont = $cb->_get_file_contents( file => '/path/to/file' );
+
+
+ my $version = $cb->_perl_version( perl => $^X );
+
+=head1 DESCRIPTION
+
+C<CPANPLUS::Internals::Utils> holds a few convenience functions for
+CPANPLUS libraries.
+
+=head1 METHODS
+
+=head2 $cb->_mkdir( dir => '/some/dir' )
+
+C<_mkdir> creates a full path to a directory.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _mkdir {
+ my $self = shift;
+
+ my %hash = @_;
+
+ my $tmpl = {
+ dir => { required => 1 },
+ };
+
+ my $args = check( $tmpl, \%hash ) or (
+ error(loc( Params::Check->last_error ) ), return
+ );
+
+ unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
+ error( loc("Could not use File::Path! This module should be core!") );
+ return;
+ }
+
+ eval { File::Path::mkpath($args->{dir}) };
+
+ if($@) {
+ chomp($@);
+ error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ ));
+ return;
+ }
+
+ return 1;
+}
+
+=pod
+
+=head2 $cb->_chdir( dir => '/some/dir' )
+
+C<_chdir> changes directory to a dir.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _chdir {
+ my $self = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ dir => { required => 1, allow => DIR_EXISTS },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ unless( chdir $args->{dir} ) {
+ error( loc(q[Could not chdir into '%1'], $args->{dir}) );
+ return;
+ }
+
+ return 1;
+}
+
+=pod
+
+=head2 $cb->_rmdir( dir => '/some/dir' );
+
+Removes a directory completely, even if it is non-empty.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _rmdir {
+ my $self = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ dir => { required => 1, allow => IS_DIR },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
+ error( loc("Could not use File::Path! This module should be core!") );
+ return;
+ }
+
+ eval { File::Path::rmtree($args->{dir}) };
+
+ if($@) {
+ chomp($@);
+ error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ ));
+ return;
+ }
+
+ return 1;
+}
+
+=pod
+
+=head2 $cb->_perl_version ( perl => 'some/perl/binary' );
+
+C<_perl_version> returns the version of a certain perl binary.
+It does this by actually running a command.
+
+Returns the perl version on success and false on failure.
+
+=cut
+
+sub _perl_version {
+ my $self = shift;
+ my %hash = @_;
+
+ my $perl;
+ my $tmpl = {
+ perl => { required => 1, store => \$perl },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my $perl_version;
+ ### special perl, or the one we are running under?
+ if( $perl eq $^X ) {
+ ### just load the config
+ require Config;
+ $perl_version = $Config::Config{version};
+
+ } else {
+ my $cmd = $perl .
+ ' -MConfig -eprint+Config::config_vars+version';
+ ($perl_version) = (`$cmd` =~ /version='(.*)'/);
+ }
+
+ return $perl_version if defined $perl_version;
+ return;
+}
+
+=pod
+
+=head2 $cb->_version_to_number( version => $version );
+
+Returns a proper module version, or '0.0' if none was available.
+
+=cut
+
+sub _version_to_number {
+ my $self = shift;
+ my %hash = @_;
+
+ my $version;
+ my $tmpl = {
+ version => { default => '0.0', store => \$version },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ return $version if $version =~ /^\.?\d/;
+ return '0.0';
+}
+
+=pod
+
+=head2 $cb->_whoami
+
+Returns the name of the subroutine you're currently in.
+
+=cut
+
+sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name }
+
+=pod
+
+=head2 _get_file_contents( file => $file );
+
+Returns the contents of a file
+
+=cut
+
+sub _get_file_contents {
+ my $self = shift;
+ my %hash = @_;
+
+ my $file;
+ my $tmpl = {
+ file => { required => 1, store => \$file }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my $fh = OPEN_FILE->($file) or return;
+ my $contents = do { local $/; <$fh> };
+
+ return $contents;
+}
+
+=pod $cb->_move( from => $file|$dir, to => $target );
+
+Moves a file or directory to the target.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _move {
+ my $self = shift;
+ my %hash = @_;
+
+ my $from; my $to;
+ my $tmpl = {
+ file => { required => 1, allow => [IS_FILE,IS_DIR],
+ store => \$from },
+ to => { required => 1, store => \$to }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ if( File::Copy::move( $from, $to ) ) {
+ return 1;
+ } else {
+ error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!));
+ return;
+ }
+}
+
+=pod $cb->_copy( from => $file|$dir, to => $target );
+
+Moves a file or directory to the target.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _copy {
+ my $self = shift;
+ my %hash = @_;
+
+ my($from,$to);
+ my $tmpl = {
+ file =>{ required => 1, allow => [IS_FILE,IS_DIR],
+ store => \$from },
+ to => { required => 1, store => \$to }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ if( File::Copy::copy( $from, $to ) ) {
+ return 1;
+ } else {
+ error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!));
+ return;
+ }
+}
+
+=head2 $cb->_mode_plus_w( file => '/path/to/file' );
+
+Sets the +w bit for the file.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _mode_plus_w {
+ my $self = shift;
+ my %hash = @_;
+
+ require File::stat;
+
+ my $file;
+ my $tmpl = {
+ file => { required => 1, allow => IS_FILE, store => \$file },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### set the mode to +w for a file and +wx for a dir
+ my $x = File::stat::stat( $file );
+ my $mask = -d $file ? 0100 : 0200;
+
+ if( $x and chmod( $x->mode|$mask, $file ) ) {
+ return 1;
+
+ } else {
+ error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!));
+ return;
+ }
+}
+
+=head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH );
+
+Turns a CPANPLUS::Config style C<host> entry into an URI string.
+
+Returns the uri on success, and false on failure
+
+=cut
+
+sub _host_to_uri {
+ my $self = shift;
+ my %hash = @_;
+
+ my($scheme, $host, $path);
+ my $tmpl = {
+ scheme => { required => 1, store => \$scheme },
+ host => { default => 'localhost', store => \$host },
+ path => { default => '', store => \$path },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### it's an URI, so unixify the path.
+ ### VMS has a special method for just that
+ $path = ON_VMS
+ ? VMS::Filespec::unixify($path)
+ : File::Spec::Unix->catdir( File::Spec->splitdir( $path ) );
+
+ return "$scheme://" . File::Spec::Unix->catdir( $host, $path );
+}
+
+=head2 $cb->_vcmp( VERSION, VERSION );
+
+Normalizes the versions passed and does a '<=>' on them, returning the result.
+
+=cut
+
+sub _vcmp {
+ my $self = shift;
+ my ($x, $y) = @_;
+
+ s/_//g foreach $x, $y;
+
+ return $x <=> $y;
+}
+
+=head2 $cb->_home_dir
+
+Returns the user's homedir, or C<cwd> if it could not be found
+
+=cut
+
+sub _home_dir {
+ my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN );
+
+ for my $env ( @os_home_envs ) {
+ next unless exists $ENV{ $env };
+ next unless defined $ENV{ $env } && length $ENV{ $env };
+ return $ENV{ $env } if -d $ENV{ $env };
+ }
+
+ return cwd();
+}
+
+=head2 $path = $cb->_safe_path( path => $path );
+
+Returns a path that's safe to us on Win32 and VMS.
+
+Only cleans up the path on Win32 if the path exists.
+
+On VMS, it encodes dots to _ using C<VMS::Filespec::vmsify>
+
+=cut
+
+sub _safe_path {
+ my $self = shift;
+
+ my %hash = @_;
+
+ my $path;
+ my $tmpl = {
+ path => { required => 1, store => \$path },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ if( ON_WIN32 ) {
+ ### only need to fix it up if there's spaces in the path
+ return $path unless $path =~ /\s+/;
+
+ ### clean up paths if we are on win32
+ return Win32::GetShortPathName( $path ) || $path;
+
+ } elsif ( ON_VMS ) {
+ ### XXX According to John Malmberg, there's an VMS issue:
+ ### catdir on VMS can not currently deal with directory components
+ ### with dots in them.
+ ### Fixing this is a a three step procedure, which will work for
+ ### VMS in its traditional ODS-2 mode, and it will also work if
+ ### VMS is in the ODS-5 mode that is being implemented.
+ ### If the path is already in VMS syntax, assume that we are done.
+
+ ### VMS format is a path with a trailing ']' or ':'
+ return $path if $path =~ /\:|\]$/;
+
+ ### 1. Make sure that the value to be converted, $path is
+ ### in UNIX directory syntax by appending a '/' to it.
+ $path .= '/' unless $path =~ m|/$|;
+
+ ### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to
+ ### underscores if needed. The trailing '/' is needed as so that
+ ### C<vmsify> knows that it should use directory translation instead of
+ ### filename translation, as filename translation leaves one dot.
+ $path = VMS::Filespec::vmsify( $path );
+
+ ### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify(
+ ### $path . '/') to remove the directory delimiters.
+
+ ### From John Malmberg:
+ ### File::Spec->catdir will put the path back together.
+ ### The '/' trick only works if the string is a directory name
+ ### with UNIX style directory delimiters or no directory delimiters.
+ ### It is to force vmsify to treat the input specification as UNIX.
+ ###
+ ### There is a VMS::Filespec::unixpath() to do the appending of the '/'
+ ### to the specification, which will do a VMS::Filespec::vmsify()
+ ### if needed.
+ ### However it is not a good idea to call vmsify() on a pathname
+ ### returned by unixify(), and it is not a good idea to call unixify()
+ ### on a pathname returned by vmsify(). Because of the nature of the
+ ### conversion, not all file specifications can make the round trip.
+ ###
+ ### I think that directory specifications can safely make the round
+ ### trip, but not ones containing filenames.
+ $path = File::Spec->catdir( File::Spec->splitdir( $path ) )
+ }
+
+ return $path;
+}
+
+
+=head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING );
+
+Splits the name of a CPAN package string up into its package, version
+and extension parts.
+
+For example, C<Foo-Bar-1.2.tar.gz> would return the following parts:
+
+ Package: Foo-Bar
+ Version: 1.2
+ Extension: tar.gz
+
+=cut
+
+{ my $del_re = qr/[-_\+]/i; # delimiter between elements
+ my $pkg_re = qr/[a-z] # any letters followed by
+ [a-z\d]* # any letters, numbers
+ (?i:\.pm)? # followed by '.pm'--authors do this :(
+ (?: # optionally repeating:
+ $del_re # followed by a delimiter
+ [a-z] # any letters followed by
+ [a-z\d]* # any letters, numbers
+ (?i:\.pm)? # followed by '.pm'--authors do this :(
+ )*
+ /xi;
+
+ my $ver_re = qr/[a-z]*\d*?[a-z]* # contains a digit and possibly letters
+ (?: # however, some start with a . only :(
+ [-._] # followed by a delimiter
+ [a-z\d]+ # and more digits and or letters
+ )*?
+ /xi;
+
+ my $ext_re = qr/[a-z] # a letter, followed by
+ [a-z\d]* # letters and or digits, optionally
+ (?:
+ \. # followed by a dot and letters
+ [a-z\d]+ # and or digits (like .tar.bz2)
+ )? # optionally
+ /xi;
+
+ my $ver_ext_re = qr/
+ ($ver_re+) # version, optional
+ (?:
+ \. # a literal .
+ ($ext_re) # extension,
+ )? # optional, but requires version
+ /xi;
+
+ ### composed regex for CPAN packages
+ my $full_re = qr/
+ ^
+ ( # the whole thing
+ ($pkg_re+) # package
+ (?:
+ $del_re # delimiter
+ $ver_ext_re # version + extension
+ )?
+ )
+ $
+ /xi;
+
+ ### composed regex for perl packages
+ my $perl = PERL_CORE;
+ my $perl_re = qr/
+ ^
+ ( # the whole thing
+ ($perl) # package name for 'perl'
+ (?:
+ $ver_ext_re # version + extension
+ )?
+ )
+ $
+ /xi;
+
+
+sub _split_package_string {
+ my $self = shift;
+ my %hash = @_;
+
+ my $str;
+ my $tmpl = { package => { required => 1, store => \$str } };
+ check( $tmpl, \%hash ) or return;
+
+
+ ### 2 different regexes, one for the 'perl' package,
+ ### one for ordinary CPAN packages.. try them both,
+ ### first match wins.
+ for my $re ( $full_re, $perl_re ) {
+
+ ### try the next if the match fails
+ $str =~ $re or next;
+
+ my $full = $1 || '';
+ my $pkg = $2 || '';
+ my $ver = $3 || '';
+ my $ext = $4 || '';
+
+ ### this regex resets the capture markers!
+ ### strip the trailing delimiter
+ $pkg =~ s/$del_re$//;
+
+ ### strip the .pm package suffix some authors insist on adding
+ $pkg =~ s/\.pm$//i;
+
+ return ($pkg, $ver, $ext, $full );
+ }
+
+ return;
+ }
+}
+
+{ my %escapes = map {
+ chr($_) => sprintf("%%%02X", $_)
+ } 0 .. 255;
+
+ sub _uri_encode {
+ my $self = shift;
+ my %hash = @_;
+
+ my $str;
+ my $tmpl = {
+ uri => { store => \$str, required => 1 }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### XXX taken straight from URI::Encode
+ ### Default unsafe characters. RFC 2732 ^(uric - reserved)
+ $str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g;
+
+ return $str;
+ }
+
+
+ sub _uri_decode {
+ my $self = shift;
+ my %hash = @_;
+
+ my $str;
+ my $tmpl = {
+ uri => { store => \$str, required => 1 }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### XXX use unencode routine in utils?
+ $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+
+ return $str;
+ }
+}
+
+sub _update_timestamp {
+ my $self = shift;
+ my %hash = @_;
+
+ my $file;
+ my $tmpl = {
+ file => { required => 1, store => \$file, allow => FILE_EXISTS }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### `touch` the file, so windoze knows it's new -jmb
+ ### works on *nix too, good fix -Kane
+ ### make sure it is writable first, otherwise the `touch` will fail
+
+ my $now = time;
+ unless( chmod( 0644, $file) && utime ($now, $now, $file) ) {
+ error( loc("Couldn't touch %1", $file) );
+ return;
+ }
+
+ return 1;
+}
+
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils/Autoflush.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils/Autoflush.pm
new file mode 100644
index 00000000000..56566436a14
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils/Autoflush.pm
@@ -0,0 +1,5 @@
+package CPANPLUS::Internals::Utils::Autoflush;
+
+BEGIN { $|++ };
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm
new file mode 100644
index 00000000000..9e4b67e4a38
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm
@@ -0,0 +1,1815 @@
+package CPANPLUS::Module;
+
+use strict;
+use vars qw[@ISA];
+
+
+use CPANPLUS::Dist;
+use CPANPLUS::Error;
+use CPANPLUS::Module::Signature;
+use CPANPLUS::Module::Checksums;
+use CPANPLUS::Internals::Constants;
+
+use FileHandle;
+
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+use IPC::Cmd qw[can_run run];
+use File::Find qw[find];
+use Params::Check qw[check];
+use File::Basename qw[dirname];
+use Module::Load::Conditional qw[can_load check_install];
+
+$Params::Check::VERBOSE = 1;
+
+@ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums];
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Module
+
+=head1 SYNOPSIS
+
+ ### get a module object from the CPANPLUS::Backend object
+ my $mod = $cb->module_tree('Some::Module');
+
+ ### accessors
+ $mod->version;
+ $mod->package;
+
+ ### methods
+ $mod->fetch;
+ $mod->extract;
+ $mod->install;
+
+
+=head1 DESCRIPTION
+
+C<CPANPLUS::Module> creates objects from the information in the
+source files. These can then be used to query and perform actions
+on, like fetching or installing.
+
+These objects should only be created internally. For C<fake> objects,
+there's the C<CPANPLUS::Module::Fake> class. To obtain a module object
+consult the C<CPANPLUS::Backend> documentation.
+
+=cut
+
+my $tmpl = {
+ module => { default => '', required => 1 }, # full module name
+ version => { default => '0.0' }, # version number
+ path => { default => '', required => 1 }, # extended path on the
+ # cpan mirror, like
+ # /author/id/K/KA/KANE
+ comment => { default => ''}, # comment on module
+ package => { default => '', required => 1 }, # package name, like
+ # 'bar-baz-1.03.tgz'
+ description => { default => '' }, # description of the
+ # module
+ dslip => { default => EMPTY_DSLIP }, # dslip information
+ _id => { required => 1 }, # id of the Internals
+ # parent object
+ _status => { no_override => 1 }, # stores status object
+ author => { default => '', required => 1,
+ allow => IS_AUTHOBJ }, # module author
+ mtime => { default => '' },
+};
+
+### some of these will be resolved by wrapper functions that
+### do Clever Things to find the actual value, so don't create
+### an autogenerated sub for that just here, take an alternate
+### name to allow for a wrapper
+{ my %rename = (
+ dslip => '_dslip'
+ );
+
+ ### autogenerate accessors ###
+ for my $key ( keys %$tmpl ) {
+ no strict 'refs';
+
+ my $sub = $rename{$key} || $key;
+
+ *{__PACKAGE__."::$sub"} = sub {
+ $_[0]->{$key} = $_[1] if @_ > 1;
+ return $_[0]->{$key};
+ }
+ }
+}
+
+
+=pod
+
+=head1 CLASS METHODS
+
+=head2 accessors ()
+
+Returns a list of all accessor methods to the object
+
+=cut
+
+### *name is an alias, include it explicitly
+sub accessors { return ('name', keys %$tmpl) };
+
+=head1 ACCESSORS
+
+An objects of this class has the following accessors:
+
+=over 4
+
+=item name
+
+Name of the module.
+
+=item module
+
+Name of the module.
+
+=item version
+
+Version of the module. Defaults to '0.0' if none was provided.
+
+=item path
+
+Extended path on the mirror.
+
+=item comment
+
+Any comment about the module -- largely unused.
+
+=item package
+
+The name of the package.
+
+=item description
+
+Description of the module -- only registered modules have this.
+
+=item dslip
+
+The five character dslip string, that represents meta-data of the
+module -- again, only registered modules have this.
+
+=cut
+
+sub dslip {
+ my $self = shift;
+
+ ### if this module has relevant dslip info, return it
+ return $self->_dslip if $self->_dslip ne EMPTY_DSLIP;
+
+ ### if not, look at other modules in the same package,
+ ### see if *they* have any dslip info
+ for my $mod ( $self->contains ) {
+ return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP;
+ }
+
+ ### ok, really no dslip info found, return the default
+ return EMPTY_DSLIP;
+}
+
+
+=pod
+
+=item status
+
+The C<CPANPLUS::Module::Status> object associated with this object.
+(see below).
+
+=item author
+
+The C<CPANPLUS::Module::Author> object associated with this object.
+
+=item parent
+
+The C<CPANPLUS::Internals> object that spawned this module object.
+
+=back
+
+=cut
+
+### Alias ->name to ->module, for human beings.
+*name = *module;
+
+sub parent {
+ my $self = shift;
+ my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id );
+
+ return $obj;
+}
+
+=head1 STATUS ACCESSORS
+
+C<CPANPLUS> caches a lot of results from method calls and saves data
+it collected along the road for later reuse.
+
+C<CPANPLUS> uses this internally, but it is also available for the end
+user. You can get a status object by calling:
+
+ $modobj->status
+
+You can then query the object as follows:
+
+=over 4
+
+=item installer_type
+
+The installer type used for this distribution. Will be one of
+'makemaker' or 'build'. This determines whether C<CPANPLUS::Dist::MM>
+or C<CPANPLUS::Dist::Build> will be used to build this distribution.
+
+=item dist_cpan
+
+The dist object used to do the CPAN-side of the installation. Either
+a C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build> object.
+
+=item dist
+
+The custom dist object used to do the operating specific side of the
+installation, if you've chosen to use this. For example, if you've
+chosen to install using the C<ports> format, this may be a
+C<CPANPLUS::Dist::Ports> object.
+
+Undefined if you didn't specify a separate format to install through.
+
+=item prereqs | requires
+
+A hashref of prereqs this distribution was found to have. Will look
+something like this:
+
+ { Carp => 0.01, strict => 0 }
+
+Might be undefined if the distribution didn't have any prerequisites.
+
+=item configure_requires
+
+Like prereqs, but these are necessary to be installed before the
+build process can even begin.
+
+=item signature
+
+Flag indicating, if a signature check was done, whether it was OK or
+not.
+
+=item extract
+
+The directory this distribution was extracted to.
+
+=item fetch
+
+The location this distribution was fetched to.
+
+=item readme
+
+The text of this distributions README file.
+
+=item uninstall
+
+Flag indicating if an uninstall call was done successfully.
+
+=item created
+
+Flag indicating if the C<create> call to your dist object was done
+successfully.
+
+=item installed
+
+Flag indicating if the C<install> call to your dist object was done
+successfully.
+
+=item checksums
+
+The location of this distributions CHECKSUMS file.
+
+=item checksum_ok
+
+Flag indicating if the checksums check was done successfully.
+
+=item checksum_value
+
+The checksum value this distribution is expected to have
+
+=back
+
+=head1 METHODS
+
+=head2 $self = CPANPLUS::Module->new( OPTIONS )
+
+This method returns a C<CPANPLUS::Module> object. Normal users
+should never call this method directly, but instead use the
+C<CPANPLUS::Backend> to obtain module objects.
+
+This example illustrates a C<new()> call with all required arguments:
+
+ CPANPLUS::Module->new(
+ module => 'Foo',
+ path => 'authors/id/A/AA/AAA',
+ package => 'Foo-1.0.tgz',
+ author => $author_object,
+ _id => INTERNALS_OBJECT_ID,
+ );
+
+Every accessor is also a valid option to pass to C<new>.
+
+Returns a module object on success and false on failure.
+
+=cut
+
+
+sub new {
+ my($class, %hash) = @_;
+
+ ### don't check the template for sanity
+ ### -- we know it's good and saves a lot of performance
+ local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
+
+ my $object = check( $tmpl, \%hash ) or return;
+
+ bless $object, $class;
+
+ return $object;
+}
+
+### only create status objects when they're actually asked for
+sub status {
+ my $self = shift;
+ return $self->_status if $self->_status;
+
+ my $acc = Object::Accessor->new;
+ $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs
+ signature extract fetch readme uninstall
+ created installed prepared checksums files
+ checksum_ok checksum_value _fetch_from
+ configure_requires
+ ] );
+
+ ### create an alias from 'requires' to 'prereqs', so it's more in
+ ### line with 'configure_requires';
+ $acc->mk_aliases( requires => 'prereqs' );
+
+ $self->_status( $acc );
+
+ return $self->_status;
+}
+
+
+### flush the cache of this object ###
+sub _flush {
+ my $self = shift;
+ $self->status->mk_flush;
+ return 1;
+}
+
+=head2 $mod->package_name( [$package_string] )
+
+Returns the name of the package a module is in. For C<Acme::Bleach>
+that might be C<Acme-Bleach>.
+
+=head2 $mod->package_version( [$package_string] )
+
+Returns the version of the package a module is in. For a module
+in the package C<Acme-Bleach-1.1.tar.gz> this would be C<1.1>.
+
+=head2 $mod->package_extension( [$package_string] )
+
+Returns the suffix added by the compression method of a package a
+certain module is in. For a module in C<Acme-Bleach-1.1.tar.gz>, this
+would be C<tar.gz>.
+
+=head2 $mod->package_is_perl_core
+
+Returns a boolean indicating of the package a particular module is in,
+is actually a core perl distribution.
+
+=head2 $mod->module_is_supplied_with_perl_core( [version => $]] )
+
+Returns a boolean indicating whether C<ANY VERSION> of this module
+was supplied with the current running perl's core package.
+
+=head2 $mod->is_bundle
+
+Returns a boolean indicating if the module you are looking at, is
+actually a bundle. Bundles are identified as modules whose name starts
+with C<Bundle::>.
+
+=head2 $mod->is_autobundle;
+
+Returns a boolean indicating if the module you are looking at, is
+actually an autobundle as generated by C<< $cb->autobundle >>.
+
+=head2 $mod->is_third_party
+
+Returns a boolean indicating whether the package is a known third-party
+module (i.e. it's not provided by the standard Perl distribution and
+is not available on the CPAN, but on a third party software provider).
+See L<Module::ThirdParty> for more details.
+
+=head2 $mod->third_party_information
+
+Returns a reference to a hash with more information about a third-party
+module. See the documentation about C<module_information()> in
+L<Module::ThirdParty> for more details.
+
+=cut
+
+{ ### fetches the test reports for a certain module ###
+ my %map = (
+ name => 0,
+ version => 1,
+ extension => 2,
+ );
+
+ while ( my($type, $index) = each %map ) {
+ my $name = 'package_' . $type;
+
+ no strict 'refs';
+ *$name = sub {
+ my $self = shift;
+ my $val = shift || $self->package;
+ my @res = $self->parent->_split_package_string( package => $val );
+
+ ### return the corresponding index from the result
+ return $res[$index] if @res;
+ return;
+ };
+ }
+
+ sub package_is_perl_core {
+ my $self = shift;
+ my $cb = $self->parent;
+
+ ### check if the package looks like a perl core package
+ return 1 if $self->package_name eq PERL_CORE;
+
+ ### address #44562: ::Module->package_is_perl_code : problem comparing
+ ### version strings -- use $cb->_vcmp to avoid warnings when version
+ ### have _ in them
+
+ my $core = $self->module_is_supplied_with_perl_core;
+ ### ok, so it's found in the core, BUT it could be dual-lifed
+ if ($core) {
+ ### if the package is newer than installed, then it's dual-lifed
+ return if $cb->_vcmp($self->version, $self->installed_version) > 0;
+
+ ### if the package is newer or equal to the corelist,
+ ### then it's dual-lifed
+ return if $cb->_vcmp( $self->version, $core ) >= 0;
+
+ ### otherwise, it's older than corelist, thus unsuitable.
+ return 1;
+ }
+
+ ### not in corelist, not a perl core package.
+ return;
+ }
+
+ sub module_is_supplied_with_perl_core {
+ my $self = shift;
+ my $ver = shift || $];
+
+ ### allow it to be called as a package function as well like:
+ ### CPANPLUS::Module::module_is_supplied_with_perl_core('Config')
+ ### so that we can check the status of modules that aren't released
+ ### to CPAN, but are part of the core.
+ my $name = ref $self ? $self->module : $self;
+
+ ### check Module::CoreList to see if it's a core package
+ require Module::CoreList;
+
+ ### Address #41157: Module::module_is_supplied_with_perl_core()
+ ### broken for perl 5.10: Module::CoreList's version key for the
+ ### hash has a different number of trailing zero than $] aka
+ ### $PERL_VERSION.
+ my $core = $Module::CoreList::version{ 0+$ver }->{ $name };
+
+ return $core;
+ }
+
+ ### make sure Bundle-Foo also gets flagged as bundle
+ sub is_bundle {
+ my $self = shift;
+
+ ### cpan'd bundle
+ return 1 if $self->module =~ /^bundle(?:-|::)/i;
+
+ ### autobundle
+ return 1 if $self->is_autobundle;
+
+ ### neither
+ return;
+ }
+
+ ### full path to a generated autobundle
+ sub is_autobundle {
+ my $self = shift;
+ my $conf = $self->parent->configure_object;
+ my $prefix = $conf->_get_build('autobundle_prefix');
+
+ return 1 if $self->module eq $prefix;
+ return;
+ }
+
+ sub is_third_party {
+ my $self = shift;
+
+ return unless can_load( modules => { 'Module::ThirdParty' => 0 } );
+
+ return Module::ThirdParty::is_3rd_party( $self->name );
+ }
+
+ sub third_party_information {
+ my $self = shift;
+
+ return unless $self->is_third_party;
+
+ return Module::ThirdParty::module_information( $self->name );
+ }
+}
+
+=pod
+
+=head2 $clone = $self->clone
+
+Clones the current module object for tinkering with.
+It will have a clean C<CPANPLUS::Module::Status> object, as well as
+a fake C<CPANPLUS::Module::Author> object.
+
+=cut
+
+{ ### accessors dont change during run time, so only compute once
+ my @acc = grep !/status/, __PACKAGE__->accessors();
+
+ sub clone {
+ my $self = shift;
+
+ ### clone the object ###
+ my %data = map { $_ => $self->$_ } @acc;
+
+ my $obj = CPANPLUS::Module::Fake->new( %data );
+
+ return $obj;
+ }
+}
+
+=pod
+
+=head2 $where = $self->fetch
+
+Fetches the module from a CPAN mirror.
+Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the
+options you can pass.
+
+=cut
+
+sub fetch {
+ my $self = shift;
+ my $cb = $self->parent;
+
+ ### custom args
+ my %args = ( module => $self );
+
+ ### if a custom fetch location got specified before, add that here
+ $args{fetch_from} = $self->status->_fetch_from
+ if $self->status->_fetch_from;
+
+ my $where = $cb->_fetch( @_, %args ) or return;
+
+ ### do an md5 check ###
+ if( !$self->status->_fetch_from and
+ $cb->configure_object->get_conf('md5') and
+ $self->package ne CHECKSUMS
+ ) {
+ unless( $self->_validate_checksum ) {
+ error( loc( "Checksum error for '%1' -- will not trust package",
+ $self->package) );
+ return;
+ }
+ }
+
+ return $where;
+}
+
+=pod
+
+=head2 $path = $self->extract
+
+Extracts the fetched module.
+Look at L<CPANPLUS::Internals::Extract::_extract()> for details on
+the options you can pass.
+
+=cut
+
+sub extract {
+ my $self = shift;
+ my $cb = $self->parent;
+
+ unless( $self->status->fetch ) {
+ error( loc( "You have not fetched '%1' yet -- cannot extract",
+ $self->module) );
+ return;
+ }
+
+ ### can't extract these, so just use the basedir for the file
+ if( $self->is_autobundle ) {
+
+ ### this is expected to be set after an extract call
+ $self->get_installer_type;
+
+ return $self->status->extract( dirname( $self->status->fetch ) );
+ }
+
+ return $cb->_extract( @_, module => $self );
+}
+
+=head2 $type = $self->get_installer_type([prefer_makefile => BOOL])
+
+Gets the installer type for this module. This may either be C<build> or
+C<makemaker>. If C<Module::Build> is unavailable or no installer type
+is available, it will fall back to C<makemaker>. If both are available,
+it will pick the one indicated by your config, or by the
+C<prefer_makefile> option you can pass to this function.
+
+Returns the installer type on success, and false on error.
+
+=cut
+
+sub get_installer_type {
+ my $self = shift;
+ my $cb = $self->parent;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my ($prefer_makefile,$verbose);
+ my $tmpl = {
+ prefer_makefile => { default => $conf->get_conf('prefer_makefile'),
+ store => \$prefer_makefile, allow => BOOLEANS },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my $type;
+
+ ### autobundles use their own installer, so return that
+ if( $self->is_autobundle ) {
+ $type = INSTALLER_AUTOBUNDLE;
+
+ } else {
+ my $extract = $self->status->extract();
+ unless( $extract ) {
+ error(loc(
+ "Cannot determine installer type of unextracted module '%1'",
+ $self->module
+ ));
+ return;
+ }
+
+ ### check if it's a makemaker or a module::build type dist ###
+ my $found_build = -e BUILD_PL->( $extract );
+ my $found_makefile = -e MAKEFILE_PL->( $extract );
+
+ $type = INSTALLER_BUILD if !$prefer_makefile && $found_build;
+ $type = INSTALLER_BUILD if $found_build && !$found_makefile;
+ $type = INSTALLER_MM if $prefer_makefile && $found_makefile;
+ $type = INSTALLER_MM if $found_makefile && !$found_build;
+ }
+
+ ### ok, so it's a 'build' installer, but you don't /have/ module build
+ ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow?
+ if( $type and $type eq INSTALLER_BUILD and (
+ not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD )
+ or not $cb->module_tree( INSTALLER_BUILD )
+ ->is_uptodate( version => '0.24' )
+ ) ) {
+
+ ### XXX this is for recording purposes only. We *have* to install
+ ### these before even creating a dist object, or we'll get an error
+ ### saying 'no such dist type';
+ ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow?
+ my $href = $self->status->configure_requires || {};
+ my $deps = { INSTALLER_BUILD, '0.24', %$href };
+
+ $self->status->configure_requires( $deps );
+
+ msg(loc("This module requires '%1' and '%2' to be installed first. ".
+ "Adding these modules to your prerequisites list",
+ 'Module::Build', INSTALLER_BUILD
+ ), $verbose );
+
+
+ ### ok, actually we found neither ###
+ } elsif ( !$type ) {
+ error( loc( "Unable to find '%1' or '%2' for '%3'; ".
+ "Will default to '%4' but might be unable ".
+ "to install!", BUILD_PL->(), MAKEFILE_PL->(),
+ $self->module, INSTALLER_MM ) );
+ $type = INSTALLER_MM;
+ }
+
+ return $self->status->installer_type( $type ) if $type;
+ return;
+}
+
+=pod
+
+=head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]);
+
+Create a distribution object, ready to be installed.
+Distribution type defaults to your config settings
+
+The optional C<args> hashref is passed on to the specific distribution
+types' C<create> method after being dereferenced.
+
+Returns a distribution object on success, false on failure.
+
+See C<CPANPLUS::Dist> for details.
+
+=cut
+
+sub dist {
+ my $self = shift;
+ my $cb = $self->parent;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ ### have you determined your installer type yet? if not, do it here,
+ ### we need the info
+ $self->get_installer_type unless $self->status->installer_type;
+
+ my($type,$args,$target);
+ my $tmpl = {
+ format => { default => $conf->get_conf('dist_type') ||
+ $self->status->installer_type,
+ store => \$type },
+ target => { default => TARGET_CREATE, store => \$target },
+ args => { default => {}, store => \$args },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### ok, check for $type. Do we have it?
+ unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
+
+ ### ok, we don't have it. Is it C::D::Build? if so we can install the
+ ### whole thing now
+ ### XXX we _could_ do this for any type we dont have actually...
+ if( $type eq INSTALLER_BUILD ) {
+ msg(loc("Bootstrapping installer '%1'", $type));
+
+ ### don't propagate the format, it's the one we're trying to
+ ### bootstrap, so it'll be an infinite loop if we do
+
+ $cb->module_tree( $type )->install( target => $target, %$args ) or
+ do {
+ error(loc("Could not bootstrap installer '%1' -- ".
+ "can not continue", $type));
+ return;
+ };
+
+ ### re-scan for available modules now
+ CPANPLUS::Dist->rescan_dist_types;
+
+ unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
+ error(loc("Newly installed installer type '%1' should be ".
+ "available, but is not! -- aborting", $type));
+ return;
+ } else {
+ msg(loc("Installer '%1' succesfully bootstrapped", $type));
+ }
+
+ ### some other plugin you dont have. Abort
+ } else {
+ error(loc("Installer type '%1' not found. Please verify your ".
+ "installation -- aborting", $type ));
+ return;
+ }
+ }
+
+ ### make sure we don't overwrite it, just in case we came
+ ### back from a ->save_state. This allows restoration to
+ ### work correctly
+ my( $dist, $dist_cpan );
+
+ unless( $dist = $self->status->dist ) {
+ $dist = $type->new( module => $self ) or return;
+ $self->status->dist( $dist );
+ }
+
+ unless( $dist_cpan = $self->status->dist_cpan ) {
+
+ $dist_cpan = $type eq $self->status->installer_type
+ ? $self->status->dist
+ : $self->status->installer_type->new( module => $self );
+
+
+ $self->status->dist_cpan( $dist_cpan );
+ }
+
+
+ DIST: {
+ ### just wanted the $dist object?
+ last DIST if $target eq TARGET_INIT;
+
+ ### first prepare the dist
+ $dist->prepare( %$args ) or return;
+ $self->status->prepared(1);
+
+ ### you just wanted us to prepare?
+ last DIST if $target eq TARGET_PREPARE;
+
+ $dist->create( %$args ) or return;
+ $self->status->created(1);
+ }
+
+ return $dist;
+}
+
+=pod
+
+=head2 $bool = $mod->prepare( )
+
+Convenience method around C<install()> that prepares a module
+without actually building it. This is equivalent to invoking C<install>
+with C<target> set to C<prepare>
+
+Returns true on success, false on failure.
+
+=cut
+
+sub prepare {
+ my $self = shift;
+ return $self->install( @_, target => TARGET_PREPARE );
+}
+
+=head2 $bool = $mod->create( )
+
+Convenience method around C<install()> that creates a module.
+This is equivalent to invoking C<install> with C<target> set to
+C<create>
+
+Returns true on success, false on failure.
+
+=cut
+
+sub create {
+ my $self = shift;
+ return $self->install( @_, target => TARGET_CREATE );
+}
+
+=head2 $bool = $mod->test( )
+
+Convenience wrapper around C<install()> that tests a module, without
+installing it.
+It's the equivalent to invoking C<install()> with C<target> set to
+C<create> and C<skiptest> set to C<0>.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub test {
+ my $self = shift;
+ return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
+}
+
+=pod
+
+=head2 $bool = $self->install([ target => 'init|prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);
+
+Installs the current module. This includes fetching it and extracting
+it, if this hasn't been done yet, as well as creating a distribution
+object for it.
+
+This means you can pass it more arguments than described above, which
+will be passed on to the relevant methods as they are called.
+
+See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and
+C<CPANPLUS::Dist> for details.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub install {
+ my $self = shift;
+ my $cb = $self->parent;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my $args; my $target; my $format;
+ { ### so we can use the rest of the args to the create calls etc ###
+ local $Params::Check::NO_DUPLICATES = 1;
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ ### targets 'dist' and 'test' are now completely ignored ###
+ my $tmpl = {
+ ### match this allow list with Dist->_resolve_prereqs
+ target => { default => TARGET_INSTALL, store => \$target,
+ allow => [TARGET_PREPARE, TARGET_CREATE,
+ TARGET_INSTALL, TARGET_INIT ] },
+ force => { default => $conf->get_conf('force'), },
+ verbose => { default => $conf->get_conf('verbose'), },
+ format => { default => $conf->get_conf('dist_type'),
+ store => \$format },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+
+ ### if this target isn't 'install', we will need to at least 'create'
+ ### every prereq, so it can build
+ ### XXX prereq_target of 'prepare' will do weird things here, and is
+ ### not supported.
+ $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL;
+
+ ### check if it's already upto date ###
+ if( $target eq TARGET_INSTALL and !$args->{'force'} and
+ !$self->package_is_perl_core() and # separate rules apply
+ ( $self->status->installed() or $self->is_uptodate ) and
+ !INSTALL_VIA_PACKAGE_MANAGER->($format)
+ ) {
+ msg(loc("Module '%1' already up to date, won't install without force",
+ $self->module), $args->{'verbose'} );
+ return $self->status->installed(1);
+ }
+
+ # if it's a non-installable core package, abort the install.
+ if( $self->package_is_perl_core() ) {
+ # if the installed is newer, say so.
+ if( $self->installed_version > $self->version ) {
+ error(loc("The core Perl %1 module '%2' (%3) is more ".
+ "recent than the latest release on CPAN (%4). ".
+ "Aborting install.",
+ $], $self->module, $self->installed_version,
+ $self->version ) );
+ # if the installed matches, say so.
+ } elsif( $self->installed_version == $self->version ) {
+ error(loc("The core Perl %1 module '%2' (%3) can only ".
+ "be installed by Perl itself. ".
+ "Aborting install.",
+ $], $self->module, $self->installed_version ) );
+ # otherwise, the installed is older; say so.
+ } else {
+ error(loc("The core Perl %1 module '%2' can only be ".
+ "upgraded from %3 to %4 by Perl itself (%5). ".
+ "Aborting install.",
+ $], $self->module, $self->installed_version,
+ $self->version, $self->package ) );
+ }
+ return;
+
+ ### it might be a known 3rd party module
+ } elsif ( $self->is_third_party ) {
+ my $info = $self->third_party_information;
+ error(loc(
+ "%1 is a known third-party module.\n\n".
+ "As it isn't available on the CPAN, CPANPLUS can't install " .
+ "it automatically. Therefore you need to install it manually " .
+ "before proceeding.\n\n".
+ "%2 is part of %3, published by %4, and should be available ".
+ "for download at the following address:\n\t%5",
+ $self->name, $self->name, $info->{name}, $info->{author},
+ $info->{url}
+ ));
+
+ return;
+ }
+
+ ### fetch it if need be ###
+ unless( $self->status->fetch ) {
+ my $params;
+ for (qw[prefer_bin fetchdir]) {
+ $params->{$_} = $args->{$_} if exists $args->{$_};
+ }
+ for (qw[force verbose]) {
+ $params->{$_} = $args->{$_} if defined $args->{$_};
+ }
+ $self->fetch( %$params ) or return;
+ }
+
+ ### extract it if need be ###
+ unless( $self->status->extract ) {
+ my $params;
+ for (qw[prefer_bin extractdir]) {
+ $params->{$_} = $args->{$_} if exists $args->{$_};
+ }
+ for (qw[force verbose]) {
+ $params->{$_} = $args->{$_} if defined $args->{$_};
+ }
+ $self->extract( %$params ) or return;
+ }
+
+ $format ||= $self->status->installer_type;
+
+ unless( $format ) {
+ error( loc( "Don't know what installer to use; " .
+ "Couldn't find either '%1' or '%2' in the extraction " .
+ "directory '%3' -- will be unable to install",
+ BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) );
+
+ $self->status->installed(0);
+ return;
+ }
+
+
+ ### do SIGNATURE checks? ###
+ ### XXX check status and not recheck EVERY time?
+ if( $conf->get_conf('signature') ) {
+ unless( $self->check_signature( verbose => $args->{verbose} ) ) {
+ error( loc( "Signature check failed for module '%1' ".
+ "-- Not trusting this module, aborting install",
+ $self->module ) );
+ $self->status->signature(0);
+
+ ### send out test report on broken sig
+ if( $conf->get_conf('cpantest') ) {
+ $cb->_send_report(
+ module => $self,
+ failed => 1,
+ buffer => CPANPLUS::Error->stack_as_string,
+ verbose => $args->{verbose},
+ force => $args->{force},
+ ) or error(loc("Failed to send test report for '%1'",
+ $self->module ) );
+ }
+
+ return;
+
+ } else {
+ ### signature OK ###
+ $self->status->signature(1);
+ }
+ }
+
+ ### a target of 'create' basically means not to run make test ###
+ ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1.
+ #$args->{'skiptest'} = 1 if $target eq 'create';
+
+ ### bundle rules apply ###
+ if( $self->is_bundle ) {
+ ### check what we need to install ###
+ my @prereqs = $self->bundle_modules();
+ unless( @prereqs ) {
+ error( loc( "Bundle '%1' does not specify any modules to install",
+ $self->module ) );
+
+ ### XXX mark an error here? ###
+ }
+ }
+
+ my $dist = $self->dist( format => $format,
+ target => $target,
+ args => $args );
+ unless( $dist ) {
+ error( loc( "Unable to create a new distribution object for '%1' " .
+ "-- cannot continue", $self->module ) );
+ return;
+ }
+
+ return 1 if $target ne TARGET_INSTALL;
+
+ my $ok = $dist->install( %$args ) ? 1 : 0;
+
+ $self->status->installed($ok);
+
+ return 1 if $ok;
+ return;
+}
+
+=pod @list = $self->bundle_modules()
+
+Returns a list of module objects the Bundle specifies.
+
+This requires you to have extracted the bundle already, using the
+C<extract()> method.
+
+Returns false on error.
+
+=cut
+
+sub bundle_modules {
+ my $self = shift;
+ my $cb = $self->parent;
+
+ unless( $self->is_bundle ) {
+ error( loc("'%1' is not a bundle", $self->module ) );
+ return;
+ }
+
+ my @files;
+
+ ### autobundles are special files generated by CPANPLUS. If we can
+ ### read the file, we can determine the prereqs
+ if( $self->is_autobundle ) {
+ my $where;
+ unless( $where = $self->status->fetch ) {
+ error(loc("Don't know where '%1' was fetched to", $self->package));
+ return;
+ }
+
+ push @files, $where
+
+ ### regular bundle::* upload
+ } else {
+ my $dir;
+ unless( $dir = $self->status->extract ) {
+ error(loc("Don't know where '%1' was extracted to", $self->module));
+ return;
+ }
+
+ find( {
+ wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
+ no_chdir => 1,
+ }, $dir );
+ }
+
+ my $prereqs = {}; my @list; my $seen = {};
+ for my $file ( @files ) {
+ my $fh = FileHandle->new($file)
+ or( error(loc("Could not open '%1' for reading: %2",
+ $file,$!)), next );
+
+ my $flag;
+ while( local $_ = <$fh> ) {
+ ### quick hack to read past the header of the file ###
+ last if $flag && m|^=head|i;
+
+ ### from perldoc cpan:
+ ### =head1 CONTENTS
+ ### In this pod section each line obeys the format
+ ### Module_Name [Version_String] [- optional text]
+ $flag = 1 if m|^=head1 CONTENTS|i;
+
+ if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
+ my $module = $1;
+ my $version = $cb->_version_to_number( version => $2 );
+
+ my $obj = $cb->module_tree($module);
+
+ unless( $obj ) {
+ error(loc("Cannot find bundled module '%1'", $module),
+ loc("-- it does not seem to exist") );
+ next;
+ }
+
+ ### make sure we list no duplicates ###
+ unless( $seen->{ $obj->module }++ ) {
+ push @list, $obj;
+ $prereqs->{ $module } =
+ $cb->_version_to_number( version => $version );
+ }
+ }
+ }
+ }
+
+ ### store the prereqs we just found ###
+ $self->status->prereqs( $prereqs );
+
+ return @list;
+}
+
+=pod
+
+=head2 $text = $self->readme
+
+Fetches the readme belonging to this module and stores it under
+C<< $obj->status->readme >>. Returns the readme as a string on
+success and returns false on failure.
+
+=cut
+
+sub readme {
+ my $self = shift;
+ my $conf = $self->parent->configure_object;
+
+ ### did we already dl the readme once? ###
+ return $self->status->readme() if $self->status->readme();
+
+ ### this should be core ###
+ return unless can_load( modules => { FileHandle => '0.0' },
+ verbose => 1,
+ );
+
+ ### get a clone of the current object, with a fresh status ###
+ my $obj = $self->clone or return;
+
+ ### munge the package name
+ my $pkg = README->( $obj );
+ $obj->package($pkg);
+
+ my $file;
+ { ### disable checksum fetches on readme downloads
+
+ my $tmp = $conf->get_conf( 'md5' );
+ $conf->set_conf( md5 => 0 );
+
+ $file = $obj->fetch;
+
+ $conf->set_conf( md5 => $tmp );
+
+ return unless $file;
+ }
+
+ ### read the file into a scalar, to store in the original object ###
+ my $fh = new FileHandle;
+ unless( $fh->open($file) ) {
+ error( loc( "Could not open file '%1': %2", $file, $! ) );
+ return;
+ }
+
+ my $in = do{ local $/; <$fh> };
+ $fh->close;
+
+ return $self->status->readme( $in );
+}
+
+=pod
+
+=head2 $version = $self->installed_version()
+
+Returns the currently installed version of this module, if any.
+
+=head2 $where = $self->installed_file()
+
+Returns the location of the currently installed file of this module,
+if any.
+
+=head2 $dir = $self->installed_dir()
+
+Returns the directory (or more accurately, the C<@INC> handle) from
+which this module was loaded, if any.
+
+=head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])
+
+Returns a boolean indicating if this module is uptodate or not.
+
+=cut
+
+### uptodate/installed functions
+{ my $map = { # hashkey, alternate rv
+ installed_version => ['version', 0 ],
+ installed_file => ['file', ''],
+ installed_dir => ['dir', ''],
+ is_uptodate => ['uptodate', 0 ],
+ };
+
+ while( my($method, $aref) = each %$map ) {
+ my($key,$alt_rv) = @$aref;
+
+ no strict 'refs';
+ *$method = sub {
+ ### never use the @INC hooks to find installed versions of
+ ### modules -- they're just there in case they're not on the
+ ### perl install, but the user shouldn't trust them for *other*
+ ### modules!
+ ### XXX CPANPLUS::inc is now obsolete, so this should not
+ ### be needed anymore
+ #local @INC = CPANPLUS::inc->original_inc;
+
+ my $self = shift;
+
+ ### make sure check_install is not looking in %INC, as
+ ### that may contain some of our sneakily loaded modules
+ ### that aren't installed as such. -- kane
+ local $Module::Load::Conditional::CHECK_INC_HASH = 0;
+ ### this should all that is required for deprecated core modules
+ local $Module::Load::Conditional::DEPRECATED = 1;
+ my $href = check_install(
+ module => $self->module,
+ version => $self->version,
+ @_,
+ );
+
+ return $href->{$key} || $alt_rv;
+ }
+ }
+}
+
+
+
+=pod
+
+=head2 $href = $self->details()
+
+Returns a hashref with key/value pairs offering more information about
+a particular module. For example, for C<Time::HiRes> it might look like
+this:
+
+ Author Jarkko Hietaniemi (jhi@iki.fi)
+ Description High resolution time, sleep, and alarm
+ Development Stage Released
+ Installed File /usr/local/perl/lib/Time/Hires.pm
+ Interface Style plain Functions, no references used
+ Language Used C and perl, a C compiler will be needed
+ Package Time-HiRes-1.65.tar.gz
+ Public License Unknown
+ Support Level Developer
+ Version Installed 1.52
+ Version on CPAN 1.65
+
+=cut
+
+sub details {
+ my $self = shift;
+ my $conf = $self->parent->configure_object();
+ my $cb = $self->parent;
+ my %hash = @_;
+
+ my $res = {
+ Author => loc("%1 (%2)", $self->author->author(),
+ $self->author->email() ),
+ Package => $self->package,
+ Description => $self->description || loc('None given'),
+ 'Version on CPAN' => $self->version,
+ };
+
+ ### check if we have the module installed
+ ### if so, add version have and version on cpan
+ $res->{'Version Installed'} = $self->installed_version
+ if $self->installed_version;
+ $res->{'Installed File'} = $self->installed_file if $self->installed_file;
+
+ my $i = 0;
+ for my $item( split '', $self->dslip ) {
+ $res->{ $cb->_dslip_defs->[$i]->[0] } =
+ $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown');
+ $i++;
+ }
+
+ return $res;
+}
+
+=head2 @list = $self->contains()
+
+Returns a list of module objects that represent the modules also
+present in the package of this module.
+
+For example, for C<Archive::Tar> this might return:
+
+ Archive::Tar
+ Archive::Tar::Constant
+ Archive::Tar::File
+
+=cut
+
+sub contains {
+ my $self = shift;
+ my $cb = $self->parent;
+ my $pkg = $self->package;
+
+ my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
+
+ return @mods;
+}
+
+=pod
+
+=head2 @list_of_hrefs = $self->fetch_report()
+
+This function queries the CPAN testers database at
+I<http://testers.cpan.org/> for test results of specified module
+objects, module names or distributions.
+
+Look at L<CPANPLUS::Internals::Report::_query_report()> for details on
+the options you can pass and the return value to expect.
+
+=cut
+
+sub fetch_report {
+ my $self = shift;
+ my $cb = $self->parent;
+
+ return $cb->_query_report( @_, module => $self );
+}
+
+=pod
+
+=head2 $bool = $self->uninstall([type => [all|man|prog])
+
+This function uninstalls the specified module object.
+
+You can install 2 types of files, either C<man> pages or C<prog>ram
+files. Alternately you can specify C<all> to uninstall both (which
+is the default).
+
+Returns true on success and false on failure.
+
+Do note that this does an uninstall via the so-called C<.packlist>,
+so if you used a module installer like say, C<ports> or C<apt>, you
+should not use this, but use your package manager instead.
+
+=cut
+
+sub uninstall {
+ my $self = shift;
+ my $conf = $self->parent->configure_object();
+ my %hash = @_;
+
+ my ($type,$verbose);
+ my $tmpl = {
+ type => { default => 'all', allow => [qw|man prog all|],
+ store => \$type },
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ force => { default => $conf->get_conf('force') },
+ };
+
+ ### XXX add a warning here if your default install dist isn't
+ ### makefile or build -- that means you are using a package manager
+ ### and this will not do what you think!
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ if( $conf->get_conf('dist_type') and (
+ ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or
+ ($conf->get_conf('dist_type') ne INSTALLER_MM))
+ ) {
+ msg(loc("You have a default installer type set (%1) ".
+ "-- you should probably use that package manager to " .
+ "uninstall modules", $conf->get_conf('dist_type')), $verbose);
+ }
+
+ ### check if we even have the module installed -- no point in continuing
+ ### otherwise
+ unless( $self->installed_version ) {
+ error( loc( "Module '%1' is not installed, so cannot uninstall",
+ $self->module ) );
+ return;
+ }
+
+ ### nothing to uninstall ###
+ my $files = $self->files( type => $type ) or return;
+ my $dirs = $self->directory_tree( type => $type ) or return;
+ my $sudo = $conf->get_program('sudo');
+
+ ### just in case there's no file; M::B doensn't provide .packlists yet ###
+ my $pack = $self->packlist;
+ $pack = $pack->[0]->packlist_file() if $pack;
+
+ ### first remove the files, then the dirs if they are empty ###
+ my $flag = 0;
+ for my $file( @$files, $pack ) {
+ next unless defined $file && -f $file;
+
+ msg(loc("Unlinking '%1'", $file), $verbose);
+
+ my @cmd = ($^X, "-eunlink+q[$file]");
+ unshift @cmd, $sudo if $sudo;
+
+ my $buffer;
+ unless ( run( command => \@cmd,
+ verbose => $verbose,
+ buffer => \$buffer )
+ ) {
+ error(loc("Failed to unlink '%1': '%2'",$file, $buffer));
+ $flag++;
+ }
+ }
+
+ for my $dir ( sort @$dirs ) {
+ local *DIR;
+ opendir DIR, $dir or next;
+ my @count = readdir(DIR);
+ close DIR;
+
+ next unless @count == 2; # . and ..
+
+ msg(loc("Removing '%1'", $dir), $verbose);
+
+ ### this fails on my win2k machines.. it indeed leaves the
+ ### dir, but it's not a critical error, since the files have
+ ### been removed. --kane
+ #unless( rmdir $dir ) {
+ # error( loc( "Could not remove '%1': %2", $dir, $! ) )
+ # unless $^O eq 'MSWin32';
+ #}
+
+ my @cmd = ($^X, "-e", "rmdir q[$dir]");
+ unshift @cmd, $sudo if $sudo;
+
+ my $buffer;
+ unless ( run( command => \@cmd,
+ verbose => $verbose,
+ buffer => \$buffer )
+ ) {
+ error(loc("Failed to rmdir '%1': %2",$dir,$buffer));
+ $flag++;
+ }
+ }
+
+ $self->status->uninstall(!$flag);
+ $self->status->installed( $flag ? 1 : undef);
+
+ return !$flag;
+}
+
+=pod
+
+=head2 @modobj = $self->distributions()
+
+Returns a list of module objects representing all releases for this
+module on success, false on failure.
+
+=cut
+
+sub distributions {
+ my $self = shift;
+ my %hash = @_;
+
+ my @list = $self->author->distributions( %hash, module => $self ) or return;
+
+ ### it's another release then by the same author ###
+ return grep { $_->package_name eq $self->package_name } @list;
+}
+
+=pod
+
+=head2 @list = $self->files ()
+
+Returns a list of files used by this module, if it is installed.
+
+=head2 @list = $self->directory_tree ()
+
+Returns a list of directories used by this module.
+
+=head2 @list = $self->packlist ()
+
+Returns the C<ExtUtils::Packlist> object for this module.
+
+=head2 @list = $self->validate ()
+
+Returns a list of files that are missing for this modules, but
+are present in the .packlist file.
+
+=cut
+
+for my $sub (qw[files directory_tree packlist validate]) {
+ no strict 'refs';
+ *$sub = sub {
+ return shift->_extutils_installed( @_, method => $sub );
+ }
+}
+
+### generic method to call an ExtUtils::Installed method ###
+sub _extutils_installed {
+ my $self = shift;
+ my $cb = $self->parent;
+ my $conf = $cb->configure_object;
+ my $home = $cb->_home_dir; # may be needed to fix up prefixes
+ my %hash = @_;
+
+ my ($verbose,$type,$method);
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose, },
+ type => { default => 'all',
+ allow => [qw|prog man all|],
+ store => \$type, },
+ method => { required => 1,
+ store => \$method,
+ allow => [qw|files directory_tree packlist
+ validate|],
+ },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we
+ ### find we're being used by them
+ { my $err = ON_OLD_CYGWIN;
+ if($err) { error($err); return };
+ }
+
+ return unless can_load(
+ modules => { 'ExtUtils::Installed' => '0.0' },
+ verbose => $verbose,
+ );
+
+ my @config_names = (
+ ### lib
+ { lib => 'privlib', # perl-only
+ arch => 'archlib', # compiled code
+ prefix => 'prefix', # prefix to both
+ },
+ ### site
+ { lib => 'sitelib',
+ arch => 'sitearch',
+ prefix => 'siteprefix',
+ },
+ ### vendor
+ { lib => 'vendorlib',
+ arch => 'vendorarch',
+ prefix => 'vendorprefix',
+ },
+ );
+
+ ### search in your regular @INC, and anything you added to your config.
+ ### this lets EU::Installed find .packlists that are *not* in the standard
+ ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438
+ ### make sure the archname path is also added, as that's where the .packlist
+ ### files are written
+ my @libs;
+ for my $lib ( @{ $conf->get_conf('lib') } ) {
+ require Config;
+
+ ### and just the standard dir
+ push @libs, $lib;
+
+ ### figure out what an MM prefix expands to. Basically, it's the
+ ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8
+ ### minus the site wide prefix, ie: /opt
+ ### this lets users add the dir they have set as their EU::MM PREFIX
+ ### to our 'lib' config and it Just Works
+ ### the arch specific dir, ie:
+ ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level
+ ### XXX is this the right thing to do?
+
+ ### we add all 6 dir combos for prefixes:
+ ### /foo/lib
+ ### /foo/lib/arch
+ ### /foo/site/lib
+ ### /foo/site/lib/arch
+ ### /foo/vendor/lib
+ ### /foo/vendor/lib/arch
+ for my $href ( @config_names ) {
+ for my $key ( qw[lib arch] ) {
+
+ ### look up the config value -- use EXP for the EXPANDED
+ ### version, so no ~ etc are found in there
+ my $dir = $Config::Config{ $href->{ $key } .'exp' } or next;
+ my $prefix = $Config::Config{ $href->{prefix} };
+
+ ### prefix may be relative to home, and contain a ~
+ ### if so, fix it up.
+ $prefix =~ s/^~/$home/;
+
+ ### remove the prefix from it, so we can append to our $lib
+ $dir =~ s/^\Q$prefix\E//;
+
+ ### do the appending
+ push @libs, File::Spec->catdir( $lib, $dir );
+
+ }
+ }
+ }
+
+ my $inst;
+ unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) {
+ error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) );
+
+ ### in case it's being used directly... ###
+ return;
+ }
+
+
+ { ### EU::Installed can die =/
+ my @files;
+ eval { @files = $inst->$method( $self->module, $type ) };
+
+ if( $@ ) {
+ chomp $@;
+ error( loc("Could not get '%1' for '%2': %3",
+ $method, $self->module, $@ ) );
+ return;
+ }
+
+ return wantarray ? @files : \@files;
+ }
+}
+
+=head2 $bool = $self->add_to_includepath;
+
+Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows
+you to add the module from its build dir to your path.
+
+You can reset C<@INC> and C<$PERL5LIB> to its original state when you
+started the program, by calling:
+
+ $self->parent->flush('lib');
+
+=cut
+
+sub add_to_includepath {
+ my $self = shift;
+ my $cb = $self->parent;
+
+ if( my $dir = $self->status->extract ) {
+
+ $cb->_add_to_includepath(
+ directories => [
+ File::Spec->catdir(BLIB->($dir), LIB),
+ File::Spec->catdir(BLIB->($dir), ARCH),
+ BLIB->($dir),
+ ]
+ ) or return;
+
+ } else {
+ error(loc( "No extract dir registered for '%1' -- can not add ".
+ "add builddir to search path!", $self->module ));
+ return;
+ }
+
+ return 1;
+
+}
+
+=pod
+
+=head2 $path = $self->best_path_to_module_build();
+
+B<OBSOLETE>
+
+If a newer version of Module::Build is found in your path, it will
+return this C<special> path. If the newest version of C<Module::Build>
+is found in your regular C<@INC>, the method will return false. This
+indicates you do not need to add a special directory to your C<@INC>.
+
+Note that this is only relevant if you're building your own
+C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have
+this taken care of.
+
+=cut
+
+### make sure we're always running 'perl Build.PL' and friends
+### against the highest version of module::build available
+sub best_path_to_module_build {
+ my $self = shift;
+
+ ### Since M::B will actually shell out and run the Build.PL, we must
+ ### make sure it refinds the proper version of M::B in the path.
+ ### that may be either in our cp::inc or in site_perl, or even a
+ ### new M::B being installed.
+ ### don't add anything else here, as that might screw up prereq checks
+
+ ### XXX this might be needed for Dist::MM too, if a makefile.pl is
+ ### masquerading as a Build.PL
+
+ ### did we find the most recent module::build in our installer path?
+
+ ### XXX can't do changes to @INC, they're being ignored by
+ ### new_from_context when writing a Build script. see ticket:
+ ### #8826 Module::Build ignores changes to @INC when writing Build
+ ### from new_from_context
+ ### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04)
+ ### and upped the version to 0.26061 of the bundled version, and things
+ ### work again
+
+ ### this functionality is now obsolete -- prereqs should be installed
+ ### and we no longer use the CPANPLUS::inc magic.. so comment this out.
+# require Module::Build;
+# if( CPANPLUS::inc->path_to('Module::Build') and (
+# CPANPLUS::inc->path_to('Module::Build') eq
+# CPANPLUS::inc->installer_path )
+# ) {
+#
+# ### if the module being installed is *not* Module::Build
+# ### itself -- as that would undoubtedly be newer -- add
+# ### the path to the installers to @INC
+# ### if it IS module::build itself, add 'lib' to its path,
+# ### as the Build.PL would do as well, but the API doesn't.
+# ### this makes self updates possible
+# return $self->module eq 'Module::Build'
+# ? 'lib'
+# : CPANPLUS::inc->installer_path;
+# }
+
+ ### otherwise, the path was found through a 'normal' way of
+ ### scanning @INC.
+ return;
+}
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+1;
+
+__END__
+
+todo:
+reports();
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm
new file mode 100644
index 00000000000..92940fa51ff
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author.pm
@@ -0,0 +1,232 @@
+package CPANPLUS::Module::Author;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+use Params::Check qw[check];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+local $Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Module::Author
+
+=head1 SYNOPSIS
+
+ my $author = CPANPLUS::Module::Author->new(
+ author => 'Jack Ashton',
+ cpanid => 'JACKASH',
+ _id => INTERNALS_OBJECT_ID,
+ );
+
+ $author->cpanid;
+ $author->author;
+ $author->email;
+
+ @dists = $author->distributions;
+ @mods = $author->modules;
+
+ @accessors = CPANPLUS::Module::Author->accessors;
+
+=head1 DESCRIPTION
+
+C<CPANPLUS::Module::Author> creates objects from the information in the
+source files. These can then be used to query on.
+
+These objects should only be created internally. For C<fake> objects,
+there's the C<CPANPLUS::Module::Author::Fake> class.
+
+=head1 ACCESSORS
+
+An objects of this class has the following accessors:
+
+=over 4
+
+=item author
+
+Name of the author.
+
+=item cpanid
+
+The CPAN id of the author.
+
+=item email
+
+The email address of the author, which defaults to '' if not provided.
+
+=item parent
+
+The C<CPANPLUS::Internals::Object> that spawned this module object.
+
+=back
+
+=cut
+
+my $tmpl = {
+ author => { required => 1 }, # full name of the author
+ cpanid => { required => 1 }, # cpan id
+ email => { default => '' }, # email address of the author
+ _id => { required => 1 }, # id of the Internals object that spawned us
+};
+
+### autogenerate accessors ###
+for my $key ( keys %$tmpl ) {
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ my $self = shift;
+ $self->{$key} = $_[0] if @_;
+ return $self->{$key};
+ }
+}
+
+sub parent {
+ my $self = shift;
+ my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id );
+
+ return $obj;
+}
+
+=pod
+
+=head1 METHODS
+
+=head2 $auth = CPANPLUS::Module::Author->new( author => AUTHOR_NAME, cpanid => CPAN_ID, _id => INTERNALS_ID [, email => AUTHOR_EMAIL] )
+
+This method returns a C<CPANPLUS::Module::Author> object, based on the given
+parameters.
+
+Returns false on failure.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ ### don't check the template for sanity
+ ### -- we know it's good and saves a lot of performance
+ local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
+
+ my $object = check( $tmpl, \%hash ) or return;
+
+ return bless $object, $class;
+}
+
+=pod
+
+=head2 @mod_objs = $auth->modules()
+
+Return a list of module objects this author has released.
+
+=cut
+
+sub modules {
+ my $self = shift;
+ my $cb = $self->parent;
+
+ my $aref = $cb->_search_module_tree(
+ type => 'author',
+ ### XXX, depending on backend, this is either an object
+ ### or the cpanid string. Dont know an elegant way to
+ ### solve this right now, so passing both
+ allow => [$self, $self->cpanid],
+ );
+ return @$aref if $aref;
+ return;
+}
+
+=pod
+
+=head2 @dists = $auth->distributions()
+
+Returns a list of module objects representing all the distributions
+this author has released.
+
+=cut
+
+sub distributions {
+ my $self = shift;
+ my %hash = @_;
+
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+ local $Params::Check::NO_DUPLICATES = 1;
+
+ my $mod;
+ my $tmpl = {
+ module => { default => '', store => \$mod },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ ### if we didn't get a module object passed, we'll find one ourselves ###
+ unless( $mod ) {
+ my @list = $self->modules;
+ if( @list ) {
+ $mod = $list[0];
+ } else {
+ error( loc( "This author has released no modules" ) );
+ return;
+ }
+ }
+
+ my $file = $mod->checksums( %hash );
+ my $href = $mod->_parse_checksums_file( file => $file ) or return;
+
+ my @rv;
+ for my $name ( keys %$href ) {
+
+ ### shortcut asap, so we avoid extra ops. On big checksums files
+ ### the call to clone() takes up a lot of time.
+ ### .meta files are now also in the checksums file,
+ ### which means we have to filter out things that dont
+ ### match our regex
+ next if $mod->package_extension( $name ) eq META_EXT;
+
+ ### used to do this wiht ->clone. However, that calls ->dslip,
+ ### (which is wrong anyway, as we're doing a different module),
+ ### which in turn calls ->contains, which scans the entire
+ ### module tree using _search_module_tree, which uses P::C
+ ### and is therefor VERY VERY slow.
+ ### so let's do this the direct way for speed ups.
+ my $dist = CPANPLUS::Module::Fake->new(
+ module => do { my $m = $mod->package_name( $name );
+ $m =~ s/-/::/g; $m;
+ },
+ version => $mod->package_version( $name ),
+ package => $name,
+ path => $mod->path, # same author after all
+ author => $mod->author, # same author after all
+ mtime => $href->{$name}->{'mtime'}, # release date
+ );
+
+ push @rv, $dist;
+ }
+
+ return @rv;
+}
+
+
+=pod
+
+=head1 CLASS METHODS
+
+=head2 accessors ()
+
+Returns a list of all accessor methods to the object
+
+=cut
+
+sub accessors { return keys %$tmpl };
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm
new file mode 100644
index 00000000000..3156c5c7abb
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Author/Fake.pm
@@ -0,0 +1,80 @@
+package CPANPLUS::Module::Author::Fake;
+
+
+use CPANPLUS::Module::Author;
+use CPANPLUS::Internals;
+use CPANPLUS::Error;
+
+use strict;
+use vars qw[@ISA];
+use Params::Check qw[check];
+
+@ISA = qw[CPANPLUS::Module::Author];
+
+$Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Module::Author::Fake
+
+=head1 SYNOPSIS
+
+ my $auth = CPANPLUS::Module::Author::Fake->new(
+ author => 'Foo Bar',
+ email => 'luser@foo.com',
+ cpanid => 'FOO',
+ _id => $cpan->id,
+ );
+
+=head1 DESCRIPTION
+
+A class for creating fake author objects, for shortcut use internally
+by CPANPLUS.
+
+Inherits from C<CPANPLUS::Module::Author>.
+
+=head1 METHODS
+
+=head2 new( _id => DIGIT )
+
+Creates a dummy author object. It can take the same options as
+C<< CPANPLUS::Module::Author->new >>, but will fill in default ones
+if none are provided. Only the _id key is required.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ author => { default => 'CPANPLUS Internals' },
+ email => { default => 'cpanplus-info@lists.sf.net' },
+ cpanid => { default => 'CPANPLUS' },
+ _id => { default => CPANPLUS::Internals->_last_id },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ my $obj = CPANPLUS::Module::Author->new( %$args ) or return;
+
+ unless( $obj->_id ) {
+ error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id'));
+ return;
+ }
+
+ ### rebless object ###
+ return bless $obj, $class;
+}
+
+1;
+
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm
new file mode 100644
index 00000000000..e1a2bbdb6ad
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Checksums.pm
@@ -0,0 +1,251 @@
+package CPANPLUS::Module::Checksums;
+
+use strict;
+use vars qw[@ISA];
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use FileHandle;
+
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+
+$Params::Check::VERBOSE = 1;
+
+@ISA = qw[ CPANPLUS::Module::Signature ];
+
+=head1 NAME
+
+CPANPLUS::Module::Checksums
+
+=head1 SYNOPSIS
+
+ $file = $modobj->checksums;
+ $bool = $mobobj->_validate_checksum;
+
+=head1 DESCRIPTION
+
+This is a class that provides functions for checking the checksum
+of a distribution. Should not be loaded directly, but used via the
+interface provided via C<CPANPLUS::Module>.
+
+=head1 METHODS
+
+=head2 $mod->checksums
+
+Fetches the checksums file for this module object.
+For the options it can take, see C<CPANPLUS::Module::fetch()>.
+
+Returns the location of the checksums file on success and false
+on error.
+
+The location of the checksums file is also stored as
+
+ $mod->status->checksums
+
+=cut
+
+sub checksums {
+ my $mod = shift or return;
+
+ my $file = $mod->_get_checksums_file( @_ );
+
+ return $mod->status->checksums( $file ) if $file;
+
+ return;
+}
+
+### checks if the package checksum matches the one
+### from the checksums file
+sub _validate_checksum {
+ my $self = shift; #must be isa CPANPLUS::Module
+ my $conf = $self->parent->configure_object;
+ my %hash = @_;
+
+ my $verbose;
+ my $tmpl = {
+ verbose => { default => $conf->get_conf('verbose'),
+ store => \$verbose },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### if we can't check it, we must assume it's ok ###
+ return $self->status->checksum_ok(1)
+ unless can_load( modules => { 'Digest::MD5' => '0.0' } );
+ #class CPANPLUS::Module::Status is runtime-generated
+
+ my $file = $self->_get_checksums_file( verbose => $verbose ) or (
+ error(loc(q[Could not fetch '%1' file], CHECKSUMS)), return );
+
+ $self->_check_signature_for_checksum_file( file => $file ) or (
+ error(loc(q[Could not verify '%1' file], CHECKSUMS)), return );
+ #for whole CHECKSUMS file
+
+ my $href = $self->_parse_checksums_file( file => $file ) or (
+ error(loc(q[Could not parse '%1' file], CHECKSUMS)), return );
+
+ my $size = $href->{ $self->package }->{'size'};
+
+ ### the checksums file tells us the size of the archive
+ ### but the downloaded file is of different size
+ if( defined $size ) {
+ if( not (-s $self->status->fetch == $size) ) {
+ error(loc( "Archive size does not match for '%1': " .
+ "size is '%2' but should be '%3'",
+ $self->package, -s $self->status->fetch, $size));
+ return $self->status->checksum_ok(0);
+ }
+ } else {
+ msg(loc("Archive size is not known for '%1'",$self->package),$verbose);
+ }
+
+ my $md5 = $href->{ $self->package }->{'md5'};
+
+ unless( defined $md5 ) {
+ msg(loc("No 'md5' checksum known for '%1'",$self->package),$verbose);
+
+ return $self->status->checksum_ok(1);
+ }
+
+ $self->status->checksum_value($md5);
+
+
+ my $fh = FileHandle->new( $self->status->fetch ) or return;
+ binmode $fh;
+
+ my $ctx = Digest::MD5->new;
+ $ctx->addfile( $fh );
+
+ my $flag = $ctx->hexdigest eq $md5;
+ $flag
+ ? msg(loc("Checksum matches for '%1'", $self->package),$verbose)
+ : error(loc("Checksum does not match for '%1': " .
+ "MD5 is '%2' but should be '%3'",
+ $self->package, $ctx->hexdigest, $md5),$verbose);
+
+
+ return $self->status->checksum_ok(1) if $flag;
+ return $self->status->checksum_ok(0);
+}
+
+
+### fetches the module objects checksum file ###
+sub _get_checksums_file {
+ my $self = shift;
+ my %hash = @_;
+
+ my $clone = $self->clone;
+ $clone->package( CHECKSUMS );
+
+ my $file = $clone->fetch( ttl => 3600, %hash ) or return;
+
+ return $file;
+}
+
+sub _parse_checksums_file {
+ my $self = shift;
+ my %hash = @_;
+
+ my $file;
+ my $tmpl = {
+ file => { required => 1, allow => FILE_READABLE, store => \$file },
+ };
+ my $args = check( $tmpl, \%hash );
+
+ my $fh = OPEN_FILE->( $file ) or return;
+
+ ### loop over the header, there might be a pgp signature ###
+ my $signed;
+ while (local $_ = <$fh>) {
+ last if /^\$cksum = \{\s*$/; # skip till this line
+ my $header = PGP_HEADER; # but be tolerant of whitespace
+ $signed = 1 if /^${header}\s*$/;# due to crossplatform linebreaks
+ }
+
+ ### read the filehandle, parse it rather than eval it, even though it
+ ### *should* be valid perl code
+ my $dist;
+ my $cksum = {};
+ while (local $_ = <$fh>) {
+
+ if (/^\s*'([^']+)' => \{\s*$/) {
+ $dist = $1;
+
+ } elsif (/^\s*'([^']+)' => '?([^'\n]+)'?,?\s*$/ and defined $dist) {
+ $cksum->{$dist}{$1} = $2;
+
+ } elsif (/^\s*}[,;]?\s*$/) {
+ undef $dist;
+
+ } elsif (/^__END__\s*$/) {
+ last;
+
+ } else {
+ error( loc("Malformed %1 line: %2", CHECKSUMS, $_) );
+ }
+ }
+
+ return $cksum;
+}
+
+sub _check_signature_for_checksum_file {
+ my $self = shift;
+
+ my $conf = $self->parent->configure_object;
+ my %hash = @_;
+
+ ### you don't want to check signatures,
+ ### so let's just return true;
+ return 1 unless $conf->get_conf('signature');
+
+ my($force,$file,$verbose);
+ my $tmpl = {
+ file => { required => 1, allow => FILE_READABLE, store => \$file },
+ force => { default => $conf->get_conf('force'), store => \$force },
+ verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ my $fh = OPEN_FILE->($file) or return;
+
+ my $signed;
+ while (local $_ = <$fh>) {
+ my $header = PGP_HEADER;
+ $signed = 1 if /^$header$/;
+ }
+
+ if ( !$signed ) {
+ msg(loc("No signature found in %1 file '%2'",
+ CHECKSUMS, $file), $verbose);
+
+ return 1 unless $force;
+
+ error( loc( "%1 file '%2' is not signed -- aborting",
+ CHECKSUMS, $file ) );
+ return;
+
+ }
+
+ if( can_load( modules => { 'Module::Signature' => '0.06' } ) ) {
+ # local $Module::Signature::SIGNATURE = $file;
+ # ... check signatures ...
+ }
+
+ return 1;
+}
+
+
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm
new file mode 100644
index 00000000000..84d0233cf83
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Fake.pm
@@ -0,0 +1,86 @@
+package CPANPLUS::Module::Fake;
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Module;
+use CPANPLUS::Module::Author::Fake;
+use CPANPLUS::Internals;
+
+use strict;
+use vars qw[@ISA];
+use Params::Check qw[check];
+
+@ISA = qw[CPANPLUS::Module];
+$Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Module::Fake
+
+=head1 SYNOPSIS
+
+ my $obj = CPANPLUS::Module::Fake->new(
+ module => 'Foo',
+ path => 'ftp/path/to/foo',
+ author => CPANPLUS::Module::Author::Fake->new,
+ package => 'fake-1.1.tgz',
+ _id => $cpan->_id,
+ );
+
+=head1 DESCRIPTION
+
+A class for creating fake module objects, for shortcut use internally
+by CPANPLUS.
+
+Inherits from C<CPANPLUS::Module>.
+
+=head1 METHODS
+
+=head2 new( module => $mod, path => $path, package => $pkg, [_id => DIGIT] )
+
+Creates a dummy module object from the above parameters. It can
+take more options (same as C<< CPANPLUS::Module->new >> but the above
+are required.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ module => { required => 1 },
+ path => { required => 1 },
+ package => { required => 1 },
+ _id => { default => CPANPLUS::Internals->_last_id },
+ author => { default => '' },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ $args->{author} ||= CPANPLUS::Module::Author::Fake->new(
+ _id => $args->{_id} );
+
+ my $obj = CPANPLUS::Module->new( %$args ) or return;
+
+ unless( $obj->_id ) {
+ error(loc("No '%1' specified -- No CPANPLUS object associated!",'_id'));
+ return;
+ }
+
+ ### rebless object ###
+ return bless $obj, $class;
+}
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm
new file mode 100644
index 00000000000..cec6f2906b0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module/Signature.pm
@@ -0,0 +1,65 @@
+package CPANPLUS::Module::Signature;
+
+use strict;
+
+
+use Cwd;
+use CPANPLUS::Error;
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+
+
+### detached sig, not actually used afaik --kane ###
+#sub get_signature {
+# my $self = shift;
+#
+# my $clone = $self->clone;
+# $clone->package( $self->package . '.sig' );
+#
+# return $clone->fetch;
+#}
+
+sub check_signature {
+ my $self = shift;
+ my $cb = $self->parent;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my $verbose;
+ my $tmpl = {
+ verbose => {default => $conf->get_conf('verbose'), store => \$verbose},
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my $dir = $self->status->extract or (
+ error( loc( "Do not know what dir '%1' was extracted to; ".
+ "Cannot check signature", $self->module ) ),
+ return );
+
+ my $cwd = cwd();
+ unless( $cb->_chdir( dir => $dir ) ) {
+ error(loc( "Could not chdir to '%1', cannot verify distribution '%2'",
+ $dir, $self->module ));
+ return;
+ }
+
+
+ ### check prerequisites
+ my $flag;
+ my $use_list = { 'Module::Signature' => '0.06' };
+ if( can_load( modules => $use_list, verbose => 1 ) ) {
+ my $rv = Module::Signature::verify();
+
+ unless ($rv eq Module::Signature::SIGNATURE_OK() or
+ $rv eq Module::Signature::SIGNATURE_MISSING()
+ ) {
+ $flag++; # whoops, bad sig
+ }
+ }
+
+ $cb->_chdir( dir => $cwd );
+ return $flag ? 0 : 1;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm
new file mode 100644
index 00000000000..48f918ce82e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm
@@ -0,0 +1,547 @@
+package CPANPLUS::Selfupdate;
+
+use strict;
+use Params::Check qw[check];
+use IPC::Cmd qw[can_run];
+use CPANPLUS::Error qw[error msg];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+use CPANPLUS::Internals::Constants;
+
+$Params::Check::VERBOSE = 1;
+
+=head1 NAME
+
+CPANPLUS::Selfupdate
+
+=head1 SYNOPSIS
+
+ $su = $cb->selfupdate_object;
+
+ @feats = $su->list_features;
+ @feats = $su->list_enabled_features;
+
+ @mods = map { $su->modules_for_feature( $_ ) } @feats;
+ @mods = $su->list_core_dependencies;
+ @mods = $su->list_core_modules;
+
+ for ( @mods ) {
+ print $_->name " should be version " . $_->version_required;
+ print "Installed version is not uptodate!"
+ unless $_->is_installed_version_sufficient;
+ }
+
+ $ok = $su->selfupdate( update => 'all', latest => 0 );
+
+=cut
+
+### a config has describing our deps etc
+{
+
+ my $Modules = {
+ dependencies => {
+ 'File::Fetch' => '0.15_02', # lynx & 404 handling
+ 'File::Spec' => '0.82',
+ 'IPC::Cmd' => '0.36', # 5.6.2 compat: 2-arg open
+ 'Locale::Maketext::Simple' => '0.01',
+ 'Log::Message' => '0.01',
+ 'Module::Load' => '0.10',
+ 'Module::Load::Conditional' => '0.31_01', # returns dir for loaded
+ # modules
+ 'version' => '0.73', # needed for M::L::C
+ # addresses #24630 and
+ # #24675
+ # Address ~0 overflow issue
+ 'Params::Check' => '0.22',
+ 'Package::Constants' => '0.01',
+ 'Term::UI' => '0.18', # option parsing
+ 'Test::Harness' => '2.62', # due to bug #19505
+ # only 2.58 and 2.60 are bad
+ 'Test::More' => '0.47', # to run our tests
+ 'Archive::Extract' => '0.16', # ./Dir bug fix
+ 'Archive::Tar' => '1.23',
+ 'IO::Zlib' => '1.04', # needed for Archive::Tar
+ 'Object::Accessor' => '0.34', # mk_aliases support
+ 'Module::CoreList' => '2.22', # deprecated core modules
+ 'Module::Pluggable' => '2.4',
+ 'Module::Loaded' => '0.01',
+ 'Parse::CPAN::Meta' => '0.02', # config_requires support
+ 'ExtUtils::Install' => '1.42', # uninstall outside @INC
+ },
+
+ features => {
+ # config_key_name => [
+ # sub { } to list module key/value pairs
+ # sub { } to check if feature is enabled
+ # ]
+ prefer_makefile => [
+ sub {
+ my $cb = shift;
+ $cb->configure_object->get_conf('prefer_makefile')
+ ? { }
+ : { 'CPANPLUS::Dist::Build' => '0.24' };
+ },
+ sub { return 1 }, # always enabled
+ ],
+ cpantest => [
+ { 'Test::Reporter' => '1.34',
+ 'Parse::CPAN::Meta' => '0.0'
+ },
+ sub {
+ my $cb = shift;
+ return $cb->configure_object->get_conf('cpantest');
+ },
+ ],
+ dist_type => [
+ sub {
+ my $cb = shift;
+ my $dist = $cb->configure_object->get_conf('dist_type');
+ return { $dist => '0.0' } if $dist;
+ return;
+ },
+ sub {
+ my $cb = shift;
+ return $cb->configure_object->get_conf('dist_type');
+ },
+ ],
+
+ md5 => [
+ {
+ 'Digest::MD5' => '0.0',
+ },
+ sub {
+ my $cb = shift;
+ return $cb->configure_object->get_conf('md5');
+ },
+ ],
+ shell => [
+ sub {
+ my $cb = shift;
+ my $dist = $cb->configure_object->get_conf('shell');
+
+ ### we bundle these shells, so don't bother having a dep
+ ### on them... If we don't do this, CPAN.pm actually detects
+ ### a recursive dependency and breaks (see #26077).
+ ### This is not an issue for CPANPLUS itself, it handles
+ ### it smartly.
+ return if $dist eq SHELL_DEFAULT or $dist eq SHELL_CLASSIC;
+ return { $dist => '0.0' } if $dist;
+ return;
+ },
+ sub { return 1 },
+ ],
+ signature => [
+ sub {
+ my $cb = shift;
+ return {
+ 'Module::Signature' => '0.06',
+ } if can_run('gpg');
+ ### leave this out -- Crypt::OpenPGP is fairly
+ ### painful to install, and broken on some platforms
+ ### so we'll just always fall back to gpg. It may
+ ### issue a warning or 2, but that's about it.
+ ### this change due to this ticket: #26914
+ # and $cb->configure_object->get_conf('prefer_bin');
+
+ return {
+ 'Crypt::OpenPGP' => '0.0',
+ 'Module::Signature' => '0.06',
+ };
+ },
+ sub {
+ my $cb = shift;
+ return $cb->configure_object->get_conf('signature');
+ },
+ ],
+ storable => [
+ { 'Storable' => '0.0' },
+ sub {
+ my $cb = shift;
+ return $cb->configure_object->get_conf('storable');
+ },
+ ],
+ sqlite_backend => [
+ { 'DBIx::Simple' => '0.0',
+ 'DBD::SQLite' => '0.0',
+ },
+ sub {
+ my $cb = shift;
+ my $conf = $cb->configure_object;
+ return $conf->get_conf('source_engine')
+ eq 'CPANPLUS::Internals::Source::SQLite'
+ },
+ ],
+ },
+ core => {
+ 'CPANPLUS' => '0.0',
+ },
+ };
+
+ sub _get_config { return $Modules }
+}
+
+=head1 METHODS
+
+=head2 $self = CPANPLUS::Selfupdate->new( $backend_object );
+
+Sets up a new selfupdate object. Called automatically when
+a new backend object is created.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $cb = shift or return;
+ return bless sub { $cb }, $class;
+}
+
+
+{ ### cache to find the relevant modules
+ my $cache = {
+ core
+ => sub { my $self = shift;
+ core => [ $self->list_core_modules ] },
+
+ dependencies
+ => sub { my $self = shift;
+ dependencies => [ $self->list_core_dependencies ] },
+
+ enabled_features
+ => sub { my $self = shift;
+ map { $_ => [ $self->modules_for_feature( $_ ) ] }
+ $self->list_enabled_features
+ },
+ features
+ => sub { my $self = shift;
+ map { $_ => [ $self->modules_for_feature( $_ ) ] }
+ $self->list_features
+ },
+ ### make sure to do 'core' first, in case
+ ### we are out of date ourselves
+ all => [ qw|core dependencies enabled_features| ],
+ };
+
+
+=head2 @cat = $self->list_categories
+
+Returns a list of categories that the C<selfupdate> method accepts.
+
+See C<selfupdate> for details.
+
+=cut
+
+ sub list_categories { return sort keys %$cache }
+
+=head2 %list = $self->list_modules_to_update( update => "core|dependencies|enabled_features|features|all", [latest => BOOL] )
+
+List which modules C<selfupdate> would upgrade. You can update either
+the core (CPANPLUS itself), the core dependencies, all features you have
+currently turned on, or all features available, or everything.
+
+The C<latest> option determines whether it should update to the latest
+version on CPAN, or if the minimal required version for CPANPLUS is
+good enough.
+
+Returns a hash of feature names and lists of module objects to be
+upgraded based on the category you provided. For example:
+
+ %list = $self->list_modules_to_update( update => 'core' );
+
+Would return:
+
+ ( core => [ $module_object_for_cpanplus ] );
+
+=cut
+
+ sub list_modules_to_update {
+ my $self = shift;
+ my $cb = $self->();
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my($type, $latest);
+ my $tmpl = {
+ update => { required => 1, store => \$type,
+ allow => [ keys %$cache ], },
+ latest => { default => 0, store => \$latest, allow => BOOLEANS },
+ };
+
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+ check( $tmpl, \%hash ) or return;
+ }
+
+ my $ref = $cache->{$type};
+
+ ### a list of ( feature1 => \@mods, feature2 => \@mods, etc )
+ my %list = UNIVERSAL::isa( $ref, 'ARRAY' )
+ ? map { $cache->{$_}->( $self ) } @$ref
+ : $ref->( $self );
+
+ ### filter based on whether we need the latest ones or not
+ for my $aref ( values %list ) {
+ $aref = [ $latest
+ ? grep { !$_->is_uptodate } @$aref
+ : grep { !$_->is_installed_version_sufficient } @$aref
+ ];
+ }
+
+ return %list;
+ }
+
+=head2 $bool = $self->selfupdate( update => "core|dependencies|enabled_features|features|all", [latest => BOOL, force => BOOL] )
+
+Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself),
+the core dependencies, all features you have currently turned on, or
+all features available, or everything.
+
+The C<latest> option determines whether it should update to the latest
+version on CPAN, or if the minimal required version for CPANPLUS is
+good enough.
+
+Returns true on success, false on error.
+
+=cut
+
+ sub selfupdate {
+ my $self = shift;
+ my $cb = $self->();
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my $force;
+ my $tmpl = {
+ force => { default => $conf->get_conf('force'), store => \$force },
+ };
+
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+ check( $tmpl, \%hash ) or return;
+ }
+
+ my %list = $self->list_modules_to_update( %hash ) or return;
+
+ ### just the modules please
+ my @mods = map { @$_ } values %list;
+
+ my $flag;
+ for my $mod ( @mods ) {
+ unless( $mod->install( force => $force ) ) {
+ $flag++;
+ error(loc("Failed to update module '%1'", $mod->name));
+ }
+ }
+
+ return if $flag;
+ return 1;
+ }
+
+}
+
+=head2 @features = $self->list_features
+
+Returns a list of features that are supported by CPANPLUS.
+
+=cut
+
+sub list_features {
+ my $self = shift;
+ return keys %{ $self->_get_config->{'features'} };
+}
+
+=head2 @features = $self->list_enabled_features
+
+Returns a list of features that are enabled in your current
+CPANPLUS installation.
+
+=cut
+
+sub list_enabled_features {
+ my $self = shift;
+ my $cb = $self->();
+
+ my @enabled;
+ for my $feat ( $self->list_features ) {
+ my $ref = $self->_get_config->{'features'}->{$feat}->[1];
+ push @enabled, $feat if $ref->($cb);
+ }
+
+ return @enabled;
+}
+
+=head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] )
+
+Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
+represent the modules required to support this feature.
+
+For a list of features, call the C<list_features> method.
+
+If the C<AS_HASH> argument is provided, no module objects are
+returned, but a hashref where the keys are names of the modules,
+and values are their minimum versions.
+
+=cut
+
+sub modules_for_feature {
+ my $self = shift;
+ my $feature = shift or return;
+ my $as_hash = shift || 0;
+ my $cb = $self->();
+
+ unless( exists $self->_get_config->{'features'}->{$feature} ) {
+ error(loc("Unknown feature '%1'", $feature));
+ return;
+ }
+
+ my $ref = $self->_get_config->{'features'}->{$feature}->[0];
+
+ ### it's either a list of modules/versions or a subroutine that
+ ### returns a list of modules/versions
+ my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb );
+
+ return unless $href; # nothing needed for the feature?
+
+ return $href if $as_hash;
+ return $self->_hashref_to_module( $href );
+}
+
+
+=head2 @mods = $self->list_core_dependencies( [AS_HASH] )
+
+Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
+represent the modules that comprise the core dependencies of CPANPLUS.
+
+If the C<AS_HASH> argument is provided, no module objects are
+returned, but a hashref where the keys are names of the modules,
+and values are their minimum versions.
+
+=cut
+
+sub list_core_dependencies {
+ my $self = shift;
+ my $as_hash = shift || 0;
+ my $cb = $self->();
+ my $href = $self->_get_config->{'dependencies'};
+
+ return $href if $as_hash;
+ return $self->_hashref_to_module( $href );
+}
+
+=head2 @mods = $self->list_core_modules( [AS_HASH] )
+
+Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
+represent the modules that comprise the core of CPANPLUS.
+
+If the C<AS_HASH> argument is provided, no module objects are
+returned, but a hashref where the keys are names of the modules,
+and values are their minimum versions.
+
+=cut
+
+sub list_core_modules {
+ my $self = shift;
+ my $as_hash = shift || 0;
+ my $cb = $self->();
+ my $href = $self->_get_config->{'core'};
+
+ return $href if $as_hash;
+ return $self->_hashref_to_module( $href );
+}
+
+sub _hashref_to_module {
+ my $self = shift;
+ my $cb = $self->();
+ my $href = shift or return;
+
+ return map {
+ CPANPLUS::Selfupdate::Module->new(
+ $cb->module_tree($_) => $href->{$_}
+ )
+ } keys %$href;
+}
+
+
+=head1 CPANPLUS::Selfupdate::Module
+
+C<CPANPLUS::Selfupdate::Module> extends C<CPANPLUS::Module> objects
+by providing accessors to aid in selfupdating CPANPLUS.
+
+These objects are returned by all methods of C<CPANPLUS::Selfupdate>
+that return module objects.
+
+=cut
+
+{ package CPANPLUS::Selfupdate::Module;
+ use base 'CPANPLUS::Module';
+
+ ### stores module name -> cpanplus required version
+ ### XXX only can deal with 1 pair!
+ my %Cache = ();
+ my $Acc = 'version_required';
+
+ sub new {
+ my $class = shift;
+ my $mod = shift or return;
+ my $ver = shift; return unless defined $ver;
+
+ my $obj = $mod->clone; # clone the module object
+ bless $obj, $class; # rebless it to our class
+
+ $obj->$Acc( $ver );
+
+ return $obj;
+ }
+
+=head2 $version = $mod->version_required
+
+Returns the version of this module required for CPANPLUS.
+
+=cut
+
+ sub version_required {
+ my $self = shift;
+ $Cache{ $self->name } = shift() if @_;
+ return $Cache{ $self->name };
+ }
+
+=head2 $bool = $mod->is_installed_version_sufficient
+
+Returns true if the installed version of this module is sufficient
+for CPANPLUS, or false if it is not.
+
+=cut
+
+
+ sub is_installed_version_sufficient {
+ my $self = shift;
+ return $self->is_uptodate( version => $self->$Acc );
+ }
+
+}
+
+1;
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell.pm
new file mode 100644
index 00000000000..854d46b16a4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell.pm
@@ -0,0 +1,341 @@
+package CPANPLUS::Shell;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Configure;
+use CPANPLUS::Internals::Constants;
+
+use Module::Load qw[load];
+use Params::Check qw[check];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+$Params::Check::VERBOSE = 1;
+
+use vars qw[@ISA $SHELL $DEFAULT];
+
+$DEFAULT = SHELL_DEFAULT;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Shell
+
+=head1 SYNOPSIS
+
+ use CPANPLUS::Shell; # load the shell indicated by your
+ # config -- defaults to
+ # CPANPLUS::Shell::Default
+
+ use CPANPLUS::Shell qw[Classic] # load CPANPLUS::Shell::Classic;
+
+ my $ui = CPANPLUS::Shell->new();
+ my $name = $ui->which; # Find out what shell you loaded
+
+ $ui->shell; # run the ui shell
+
+
+=head1 DESCRIPTION
+
+This module is the generic loading (and base class) for all C<CPANPLUS>
+shells. Through this module you can load any installed C<CPANPLUS>
+shell.
+
+Just about all the functionality is provided by the shell that you have
+loaded, and not by this class (which merely functions as a generic
+loading class), so please consult the documentation of your shell of
+choice.
+
+=cut
+
+sub import {
+ my $class = shift;
+ my $option = shift;
+
+ ### find out what shell we're supposed to load ###
+ $SHELL = $option
+ ? $class . '::' . $option
+ : do { ### XXX this should offer to reconfigure
+ ### CPANPLUS, somehow. --rs
+ ### XXX load Configure only if we really have to
+ ### as that means any $Conf passed later on will
+ ### be ignored in favour of the one that was
+ ### retrieved via ->new --kane
+ my $conf = CPANPLUS::Configure->new() or
+ die loc("No configuration available -- aborting") . $/;
+ $conf->get_conf('shell') || $DEFAULT;
+ };
+
+ ### load the shell, fall back to the default if required
+ ### and die if even that doesn't work
+ EVAL: {
+ eval { load $SHELL };
+
+ if( $@ ) {
+ my $err = $@;
+
+ die loc("Your default shell '%1' is not available: %2",
+ $DEFAULT, $err) .
+ loc("Check your installation!") . "\n"
+ if $SHELL eq $DEFAULT;
+
+ warn loc("Failed to use '%1': %2", $SHELL, $err),
+ loc("Switching back to the default shell '%1'", $DEFAULT),
+ "\n";
+
+ $SHELL = $DEFAULT;
+ redo EVAL;
+ }
+ }
+ @ISA = ($SHELL);
+}
+
+sub which { return $SHELL }
+
+1;
+
+###########################################################################
+### abstracted out subroutines available to programmers of other shells ###
+###########################################################################
+
+package CPANPLUS::Shell::_Base::ReadLine;
+
+use strict;
+use vars qw($AUTOLOAD $TMPL);
+
+use FileHandle;
+use CPANPLUS::Error;
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+$Params::Check::VERBOSE = 1;
+
+
+$TMPL = {
+ brand => { default => '', strict_type => 1 },
+ prompt => { default => '> ', strict_type => 1 },
+ pager => { default => '' },
+ backend => { default => '' },
+ term => { default => '' },
+ format => { default => '' },
+ dist_format => { default => '' },
+ remote => { default => undef },
+ noninteractive => { default => '' },
+ cache => { default => [ ] },
+ settings => { default => { install_all_prereqs => undef },
+ no_override => 1 },
+ _old_sigpipe => { default => '', no_override => 1 },
+ _old_outfh => { default => '', no_override => 1 },
+ _signals => { default => { INT => { } }, no_override => 1 },
+};
+
+### autogenerate accessors ###
+for my $key ( keys %$TMPL ) {
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ my $self = shift;
+ $self->{$key} = $_[0] if @_;
+ return $self->{$key};
+ }
+}
+
+sub _init {
+ my $class = shift;
+ my %hash = @_;
+
+ my $self = check( $TMPL, \%hash ) or return;
+
+ bless $self, $class;
+
+ ### signal handler ###
+ $SIG{INT} = $self->_signals->{INT}->{handler} =
+ sub {
+ unless ( $self->_signals->{INT}->{count}++ ) {
+ warn loc("Caught SIGINT"), "\n";
+ } else {
+ warn loc("Got another SIGINT"), "\n"; die;
+ }
+ };
+ ### end sig handler ###
+
+ return $self;
+}
+
+### display shell's banner, takes the Backend object as argument
+sub _show_banner {
+ my $self = shift;
+ my $cpan = $self->backend;
+ my $term = $self->term;
+
+ ### Tries to probe for our ReadLine support status
+ # a) under an interactive shell?
+ my $rl_avail = (!$term->isa('CPANPLUS::Shell::_Faked'))
+ # b) do we have a tty terminal?
+ ? (-t STDIN)
+ # c) should we enable the term?
+ ? (!$self->__is_bad_terminal($term))
+ # d) external modules available?
+ ? ($term->ReadLine ne "Term::ReadLine::Stub")
+ # a+b+c+d => "Smart" terminal
+ ? loc("enabled")
+ # a+b+c => "Stub" terminal
+ : loc("available (try 'i Term::ReadLine::Perl')")
+ # a+b => "Bad" terminal
+ : loc("disabled")
+ # a => "Dumb" terminal
+ : loc("suppressed")
+ # none => "Faked" terminal
+ : loc("suppressed in batch mode");
+
+ $rl_avail = loc("ReadLine support %1.", $rl_avail);
+ $rl_avail = "\n*** $rl_avail" if (length($rl_avail) > 45);
+
+ $self->__print(
+ loc("%1 -- CPAN exploration and module installation (v%2)",
+ $self->which, $self->which->VERSION()), "\n",
+ loc("*** Please report bugs to <bug-cpanplus\@rt.cpan.org>."), "\n",
+ loc("*** Using CPANPLUS::Backend v%1. %2",
+ $cpan->VERSION, $rl_avail), "\n\n"
+ );
+}
+
+### checks whether the Term::ReadLine is broken and needs to fallback to Stub
+sub __is_bad_terminal {
+ my $self = shift;
+ my $term = $self->term;
+
+ return unless $^O eq 'MSWin32';
+
+ ### replace the term with the default (stub) one
+ return $self->term(Term::ReadLine::Stub->new( $self->brand ) );
+}
+
+### open a pager handle
+sub _pager_open {
+ my $self = shift;
+ my $cpan = $self->backend;
+ my $cmd = $cpan->configure_object->get_program('pager') or return;
+
+ $self->_old_sigpipe( $SIG{PIPE} );
+ $SIG{PIPE} = 'IGNORE';
+
+ my $fh = new FileHandle;
+ unless ( $fh->open("| $cmd") ) {
+ error(loc("could not pipe to %1: %2\n", $cmd, $!) );
+ return;
+ }
+
+ $fh->autoflush(1);
+
+ $self->pager( $fh );
+ $self->_old_outfh( select $fh );
+
+ return $fh;
+}
+
+### print to the current pager handle, or STDOUT if it's not opened
+sub _pager_close {
+ my $self = shift;
+ my $pager = $self->pager or return;
+
+ $pager->close if (ref($pager) and $pager->can('close'));
+
+ $self->pager( undef );
+
+ select $self->_old_outfh;
+ $SIG{PIPE} = $self->_old_sigpipe;
+
+ return 1;
+}
+
+
+
+{
+ my $win32_console;
+
+ ### determines row count of current terminal; defaults to 25.
+ ### used by the pager functions
+ sub _term_rowcount {
+ my $self = shift;
+ my $cpan = $self->backend;
+ my %hash = @_;
+
+ my $default;
+ my $tmpl = {
+ default => { default => 25, allow => qr/^\d$/,
+ store => \$default }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ if ( $^O eq 'MSWin32' ) {
+ if ( can_load( modules => { 'Win32::Console' => '0.0' } ) ) {
+ $win32_console ||= Win32::Console->new();
+ my $rows = ($win32_console->Info)[-1];
+ return $rows;
+ }
+
+ } else {
+ local $Module::Load::Conditional::VERBOSE = 0;
+ if ( can_load(modules => {'Term::Size' => '0.0'}) ) {
+ my ($cols, $rows) = Term::Size::chars();
+ return $rows;
+ }
+ }
+ return $default;
+ }
+}
+
+### Custom print routines, mainly to be able to catch output
+### in test cases, or redirect it if need be
+{ sub __print {
+ my $self = shift;
+ print @_;
+ }
+
+ sub __printf {
+ my $self = shift;
+ my $fmt = shift;
+
+ ### MUST specify $fmt as a seperate param, and not as part
+ ### of @_, as it will then miss the $fmt and return the
+ ### number of elements in the list... =/ --kane
+ $self->__print( sprintf( $fmt, @_ ) );
+ }
+}
+
+1;
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell::Classic>, L<cpanp>
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Classic.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Classic.pm
new file mode 100644
index 00000000000..08c03bcf383
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Classic.pm
@@ -0,0 +1,1236 @@
+##################################################
+### CPANPLUS/Shell/Classic.pm ###
+### Backwards compatible shell for CPAN++ ###
+### Written 08-04-2002 by Jos Boumans ###
+##################################################
+
+package CPANPLUS::Shell::Classic;
+
+use strict;
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Backend;
+use CPANPLUS::Configure::Setup;
+use CPANPLUS::Internals::Constants;
+
+use Cwd;
+use IPC::Cmd;
+use Term::UI;
+use Data::Dumper;
+use Term::ReadLine;
+
+use Module::Load qw[load];
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+
+$Params::Check::VERBOSE = 1;
+$Params::Check::ALLOW_UNKNOWN = 1;
+
+BEGIN {
+ use vars qw[ $VERSION @ISA ];
+ @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ];
+ $VERSION = '0.0562';
+}
+
+load CPANPLUS::Shell;
+
+
+### our command set ###
+my $map = {
+ a => '_author',
+ b => '_bundle',
+ d => '_distribution',
+ 'm' => '_module',
+ i => '_find_all',
+ r => '_uptodate',
+ u => '_not_supported',
+ ls => '_ls',
+ get => '_fetch',
+ make => '_install',
+ test => '_install',
+ install => '_install',
+ clean => '_not_supported',
+ look => '_shell',
+ readme => '_readme',
+ h => '_help',
+ '?' => '_help',
+ o => '_set_conf',
+ reload => '_reload',
+ autobundle => '_autobundle',
+ '!' => '_bang',
+ #'q' => '_quit', # done it the loop itself
+};
+
+### the shell object, scoped to the file ###
+my $Shell;
+my $Brand = 'cpan';
+my $Prompt = $Brand . '> ';
+
+sub new {
+ my $class = shift;
+
+ my $cb = new CPANPLUS::Backend;
+ my $self = $class->SUPER::_init(
+ brand => $Brand,
+ term => Term::ReadLine->new( $Brand ),
+ prompt => $Prompt,
+ backend => $cb,
+ format => "%5s %-50s %8s %-10s\n",
+ );
+ ### make it available package wide ###
+ $Shell = $self;
+
+ ### enable verbose, it's the cpan.pm way
+ $cb->configure_object->set_conf( verbose => 1 );
+
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'install_prerequisite',
+ code => \&__ask_about_install,
+ );
+
+ ### register test report callback ###
+ $cb->_register_callback(
+ name => 'edit_test_report',
+ code => \&__ask_about_test_report,
+ );
+
+ return $self;
+}
+
+sub shell {
+ my $self = shift;
+ my $term = $self->term;
+
+ $self->_show_banner;
+ $self->_input_loop && print "\n";
+ $self->_quit;
+}
+
+sub _input_loop {
+ my $self = shift;
+ my $term = $self->term;
+ my $cb = $self->backend;
+
+ my $normal_quit = 0;
+ while (
+ defined (my $input = eval { $term->readline($self->prompt) } )
+ or $self->_signals->{INT}{count} == 1
+ ) {
+ ### re-initiate all signal handlers
+ while (my ($sig, $entry) = each %{$self->_signals} ) {
+ $SIG{$sig} = $entry->{handler} if exists($entry->{handler});
+ }
+
+ last if $self->_dispatch_on_input( input => $input );
+
+ ### flush the lib cache ###
+ $cb->_flush( list => [qw|lib load|] );
+
+ } continue {
+ $self->_signals->{INT}{count}--
+ if $self->_signals->{INT}{count}; # clear the sigint count
+ }
+
+ return 1;
+}
+
+sub _dispatch_on_input {
+ my $self = shift;
+ my $conf = $self->backend->configure_object();
+ my $term = $self->term;
+ my %hash = @_;
+
+ my $string;
+ my $tmpl = {
+ input => { required => 1, store => \$string }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### the original force setting;
+ my $force_store = $conf->get_conf( 'force' );
+
+ ### parse the input: the first part before the space
+ ### is the command, followed by arguments.
+ ### see the usage below
+ my $key;
+ PARSE_INPUT: {
+ $string =~ s|^\s*([\w\?\!]+)\s*||;
+ chomp $string;
+ $key = lc($1);
+ }
+
+ ### you prefixed the input with 'force'
+ ### that means we set the force flag, and
+ ### reparse the input...
+ ### YAY goto block :)
+ if( $key eq 'force' ) {
+ $conf->set_conf( force => 1 );
+ goto PARSE_INPUT;
+ }
+
+ ### you want to quit
+ return 1 if $key =~ /^q/;
+
+ my $method = $map->{$key};
+ unless( $self->can( $method ) ) {
+ print "Unknown command '$key'. Type ? for help.\n";
+ return;
+ }
+
+ ### dispatch the method call
+ eval { $self->$method(
+ command => $key,
+ result => [ split /\s+/, $string ],
+ input => $string );
+ };
+ warn $@ if $@;
+
+ return;
+}
+
+### displays quit message
+sub _quit {
+
+ ### well, that's what CPAN.pm says...
+ print "Lockfile removed\n";
+}
+
+sub _not_supported {
+ my $self = shift;
+ my %hash = @_;
+
+ my $cmd;
+ my $tmpl = {
+ command => { required => 1, store => \$cmd }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ print "Sorry, the command '$cmd' is not supported\n";
+
+ return;
+}
+
+sub _fetch {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my($aref, $input);
+ my $tmpl = {
+ result => { store => \$aref, default => [] },
+ input => { default => 'all', store => \$input },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ for my $mod (@$aref) {
+ my $obj;
+
+ unless( $obj = $cb->module_tree($mod) ) {
+ print "Warning: Cannot get $input, don't know what it is\n";
+ print "Try the command\n\n";
+ print "\ti /$mod/\n\n";
+ print "to find objects with matching identifiers.\n";
+
+ next;
+ }
+
+ $obj->fetch && $obj->extract;
+ }
+
+ return $aref;
+}
+
+sub _install {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my $mapping = {
+ make => { target => TARGET_CREATE, skiptest => 1 },
+ test => { target => TARGET_CREATE },
+ install => { target => TARGET_INSTALL },
+ };
+
+ my($aref,$cmd);
+ my $tmpl = {
+ result => { store => \$aref, default => [] },
+ command => { required => 1, store => \$cmd, allow => [keys %$mapping] },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ for my $mod (@$aref) {
+ my $obj = $cb->module_tree( $mod );
+
+ unless( $obj ) {
+ print "No such module '$mod'\n";
+ next;
+ }
+
+ my $opts = $mapping->{$cmd};
+ $obj->install( %$opts );
+ }
+
+ return $aref;
+}
+
+sub _shell {
+ my $self = shift;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my($aref, $cmd);
+ my $tmpl = {
+ result => { store => \$aref, default => [] },
+ command => { required => 1, store => \$cmd },
+
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+
+ my $shell = $conf->get_program('shell');
+ unless( $shell ) {
+ print "Your configuration does not define a value for subshells.\n".
+ qq[Please define it with "o conf shell <your shell>"\n];
+ return;
+ }
+
+ my $cwd = Cwd::cwd();
+
+ for my $mod (@$aref) {
+ print "Running $cmd for $mod\n";
+
+ my $obj = $cb->module_tree( $mod ) or next;
+ $obj->fetch or next;
+ $obj->extract or next;
+
+ $cb->_chdir( dir => $obj->status->extract ) or next;
+
+ #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt;
+ if( system($shell) and $! ) {
+ print "Error executing your subshell '$shell': $!\n";
+ next;
+ }
+ }
+ $cb->_chdir( dir => $cwd );
+
+ return $aref;
+}
+
+sub _readme {
+ my $self = shift;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my($aref, $cmd);
+ my $tmpl = {
+ result => { store => \$aref, default => [] },
+ command => { required => 1, store => \$cmd },
+
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ for my $mod (@$aref) {
+ my $obj = $cb->module_tree( $mod ) or next;
+
+ if( my $readme = $obj->readme ) {
+
+ $self->_pager_open;
+ print $readme;
+ $self->_pager_close;
+ }
+ }
+
+ return 1;
+}
+
+sub _reload {
+ my $self = shift;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my($input, $cmd);
+ my $tmpl = {
+ input => { default => 'all', store => \$input },
+ command => { required => 1, store => \$cmd },
+
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ if ( $input =~ /cpan/i ) {
+ print qq[You want to reload the CPAN code\n];
+ print qq[Just type 'q' and then restart... ] .
+ qq[Trust me, it is MUCH safer\n];
+
+ } elsif ( $input =~ /index/i ) {
+ $cb->reload_indices(update_source => 1);
+
+ } else {
+ print qq[cpan re-evals the CPANPLUS.pm file\n];
+ print qq[index re-reads the index files\n];
+ }
+
+ return 1;
+}
+
+sub _autobundle {
+ my $self = shift;
+ my $cb = $self->backend;
+
+ print qq[Writing bundle file... This may take a while\n];
+
+ my $where = $cb->autobundle();
+
+ print $where
+ ? qq[\nWrote autobundle to $where\n]
+ : qq[\nCould not create autobundle\n];
+
+ return 1;
+}
+
+sub _set_conf {
+ my $self = shift;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my($aref, $input);
+ my $tmpl = {
+ result => { store => \$aref, default => [] },
+ input => { default => 'all', store => \$input },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my $type = shift @$aref;
+
+ if( $type eq 'debug' ) {
+ print qq[Sorry you cannot set debug options through ] .
+ qq[this shell in CPANPLUS\n];
+ return;
+
+ } elsif ( $type eq 'conf' ) {
+
+ ### from CPAN.pm :o)
+ # CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
+ # should have been called set and 'o debug' maybe 'set debug'
+
+ # commit Commit changes to disk
+ # defaults Reload defaults from disk
+ # init Interactive setting of all options
+
+ my $name = shift @$aref;
+ my $value = "@$aref";
+
+ if( $name eq 'init' ) {
+ my $setup = CPANPLUS::Configure::Setup->new(
+ conf => $cb->configure_object,
+ term => $self->term,
+ backend => $cb,
+ );
+ return $setup->init;
+
+ } elsif ($name eq 'commit' ) {;
+ $cb->configure_object->save;
+ print "Your CPAN++ configuration info has been saved!\n\n";
+ return;
+
+ } elsif ($name eq 'defaults' ) {
+ print qq[Sorry, CPANPLUS cannot restore default for you.\n] .
+ qq[Perhaps you should run the interactive setup again.\n] .
+ qq[\ttry running 'o conf init'\n];
+ return;
+
+ ### we're just supplying things in the 'conf' section now,
+ ### not the program section.. it's a bit of a hassle to make that
+ ### work cleanly with the original CPAN.pm interface, so we'll fix
+ ### it when people start complaining, which is hopefully never.
+ } else {
+ unless( $name ) {
+ my @list = grep { $_ ne 'hosts' }
+ $conf->options( type => $type );
+
+ my $method = 'get_' . $type;
+
+ local $Data::Dumper::Indent = 0;
+ for my $name ( @list ) {
+ my $val = $conf->$method($name);
+ ($val) = ref($val)
+ ? (Data::Dumper::Dumper($val) =~ /= (.*);$/)
+ : "'$val'";
+ printf " %-25s %s\n", $name, $val;
+ }
+
+ } elsif ( $name eq 'hosts' ) {
+ print "Setting hosts is not trivial.\n" .
+ "It is suggested you edit the " .
+ "configuration file manually";
+
+ } else {
+ my $method = 'set_' . $type;
+ if( $conf->$method($name => defined $value ? $value : '') ) {
+ my $set_to = defined $value ? $value : 'EMPTY STRING';
+ print "Key '$name' was set to '$set_to'\n";
+ }
+ }
+ }
+ } else {
+ print qq[Known options:\n] .
+ qq[ conf set or get configuration variables\n] .
+ qq[ debug set or get debugging options\n];
+ }
+
+ return;
+}
+
+########################
+### search functions ###
+########################
+
+sub _author {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my($aref, $short, $input, $class);
+ my $tmpl = {
+ result => { store => \$aref, default => ['/./'] },
+ short => { default => 0, store => \$short },
+ input => { default => 'all', store => \$input },
+ class => { default => 'Author', no_override => 1,
+ store => \$class },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my @regexes = map { m|/(.+)/| ? qr/$1/ : $_ } @$aref;
+
+
+ my @rv;
+ for my $type (qw[author cpanid]) {
+ push @rv, $cb->search( type => $type, allow => \@regexes );
+ }
+
+ unless( @rv ) {
+ print "No object of type $class found for argument $input\n"
+ unless $short;
+ return;
+ }
+
+ return $self->_pp_author(
+ result => \@rv,
+ class => $class,
+ short => $short,
+ input => $input );
+
+}
+
+### find all modules matching a query ###
+sub _module {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my($aref, $short, $input, $class);
+ my $tmpl = {
+ result => { store => \$aref, default => ['/./'] },
+ short => { default => 0, store => \$short },
+ input => { default => 'all', store => \$input },
+ class => { default => 'Module', no_override => 1,
+ store => \$class },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my @rv;
+ for my $module (@$aref) {
+ if( $module =~ m|/(.+)/| ) {
+ push @rv, $cb->search( type => 'module',
+ allow => [qr/$1/i] );
+ } else {
+ my $obj = $cb->module_tree( $module ) or next;
+ push @rv, $obj;
+ }
+ }
+
+ return $self->_pp_module(
+ result => \@rv,
+ class => $class,
+ short => $short,
+ input => $input );
+}
+
+### find all bundles matching a query ###
+sub _bundle {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my($aref, $short, $input, $class);
+ my $tmpl = {
+ result => { store => \$aref, default => ['/./'] },
+ short => { default => 0, store => \$short },
+ input => { default => 'all', store => \$input },
+ class => { default => 'Bundle', no_override => 1,
+ store => \$class },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my @rv;
+ for my $bundle (@$aref) {
+ if( $bundle =~ m|/(.+)/| ) {
+ push @rv, $cb->search( type => 'module',
+ allow => [qr/Bundle::.*?$1/i] );
+ } else {
+ my $obj = $cb->module_tree( "Bundle::${bundle}" ) or next;
+ push @rv, $obj;
+ }
+ }
+
+ return $self->_pp_module(
+ result => \@rv,
+ class => $class,
+ short => $short,
+ input => $input );
+}
+
+sub _distribution {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my($aref, $short, $input, $class);
+ my $tmpl = {
+ result => { store => \$aref, default => ['/./'] },
+ short => { default => 0, store => \$short },
+ input => { default => 'all', store => \$input },
+ class => { default => 'Distribution', no_override => 1,
+ store => \$class },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my @rv;
+ for my $module (@$aref) {
+ ### if it's a regex... ###
+ if ( my ($match) = $module =~ m|^/(.+)/$|) {
+
+ ### something like /FOO/Bar.tar.gz/ was entered
+ if (my ($path,$package) = $match =~ m|^/?(.+)/(.+)$|) {
+ my $seen;
+
+ my @data = $cb->search( type => 'package',
+ allow => [qr/$package/i] );
+
+ my @list = $cb->search( type => 'path',
+ allow => [qr/$path/i],
+ data => \@data );
+
+ ### make sure we dont list the same dist twice
+ for my $val ( @list ) {
+ next if $seen->{$val->package}++;
+
+ push @rv, $val;
+ }
+
+ ### something like /FOO/ or /Bar.tgz/ was entered
+ ### so we look both in the path, as well as in the package name
+ } else {
+ my $seen;
+ { my @list = $cb->search( type => 'package',
+ allow => [qr/$match/i] );
+
+ ### make sure we dont list the same dist twice
+ for my $val ( @list ) {
+ next if $seen->{$val->package}++;
+
+ push @rv, $val;
+ }
+ }
+
+ { my @list = $cb->search( type => 'path',
+ allow => [qr/$match/i] );
+
+ ### make sure we dont list the same dist twice
+ for my $val ( @list ) {
+ next if $seen->{$val->package}++;
+
+ push @rv, $val;
+ }
+
+ }
+ }
+
+ } else {
+
+ ### user entered a full dist, like: R/RC/RCAPUTO/POE-0.19.tar.gz
+ if (my ($path,$package) = $module =~ m|^/?(.+)/(.+)$|) {
+ my @data = $cb->search( type => 'package',
+ allow => [qr/^$package$/] );
+ my @list = $cb->search( type => 'path',
+ allow => [qr/$path$/i],
+ data => \@data);
+
+ ### make sure we dont list the same dist twice
+ my $seen;
+ for my $val ( @list ) {
+ next if $seen->{$val->package}++;
+
+ push @rv, $val;
+ }
+ }
+ }
+ }
+
+ return $self->_pp_distribution(
+ result => \@rv,
+ class => $class,
+ short => $short,
+ input => $input );
+}
+
+sub _find_all {
+ my $self = shift;
+
+ my @rv;
+ for my $method (qw[_author _bundle _module _distribution]) {
+ my $aref = $self->$method( @_, short => 1 );
+
+ push @rv, @$aref if $aref;
+ }
+
+ print scalar(@rv). " items found\n"
+}
+
+sub _uptodate {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my($aref, $short, $input, $class);
+ my $tmpl = {
+ result => { store => \$aref, default => ['/./'] },
+ short => { default => 0, store => \$short },
+ input => { default => 'all', store => \$input },
+ class => { default => 'Uptodate', no_override => 1,
+ store => \$class },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+
+ my @rv;
+ if( @$aref) {
+ for my $module (@$aref) {
+ if( $module =~ m|/(.+)/| ) {
+ my @list = $cb->search( type => 'module',
+ allow => [qr/$1/i] );
+
+ ### only add those that are installed and not core
+ push @rv, grep { not $_->package_is_perl_core }
+ grep { $_->installed_file }
+ @list;
+
+ } else {
+ my $obj = $cb->module_tree( $module ) or next;
+ push @rv, $obj;
+ }
+ }
+ } else {
+ @rv = @{$cb->_all_installed};
+ }
+
+ return $self->_pp_uptodate(
+ result => \@rv,
+ class => $class,
+ short => $short,
+ input => $input );
+}
+
+sub _ls {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my($aref, $short, $input, $class);
+ my $tmpl = {
+ result => { store => \$aref, default => [] },
+ short => { default => 0, store => \$short },
+ input => { default => 'all', store => \$input },
+ class => { default => 'Uptodate', no_override => 1,
+ store => \$class },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my @rv;
+ for my $name (@$aref) {
+ my $auth = $cb->author_tree( uc $name );
+
+ unless( $auth ) {
+ print qq[ls command rejects argument $name: not an author\n];
+ next;
+ }
+
+ push @rv, $auth->distributions;
+ }
+
+ return $self->_pp_ls(
+ result => \@rv,
+ class => $class,
+ short => $short,
+ input => $input );
+}
+
+############################
+### pretty printing subs ###
+############################
+
+
+sub _pp_author {
+ my $self = shift;
+ my %hash = @_;
+
+ my( $aref, $short, $class, $input );
+ my $tmpl = {
+ result => { required => 1, default => [], strict_type => 1,
+ store => \$aref },
+ short => { default => 0, store => \$short },
+ class => { required => 1, store => \$class },
+ input => { required => 1, store => \$input },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### no results
+ if( !@$aref ) {
+ print "No objects of type $class found for argument $input\n"
+ unless $short;
+
+ ### one result, long output desired;
+ } elsif( @$aref == 1 and !$short ) {
+
+ ### should look like this:
+ #cpan> a KANE
+ #Author id = KANE
+ # EMAIL boumans@frg.eur.nl
+ # FULLNAME Jos Boumans
+
+ my $obj = shift @$aref;
+
+ print "$class id = ", $obj->cpanid(), "\n";
+ printf " %-12s %s\n", 'EMAIL', $obj->email();
+ printf " %-12s %s%s\n", 'FULLNAME', $obj->author();
+
+ } else {
+
+ ### should look like this:
+ #Author KANE (Jos Boumans)
+ #Author LBROCARD (Leon Brocard)
+ #2 items found
+
+ for my $obj ( @$aref ) {
+ printf qq[%-15s %s ("%s" (%s))\n],
+ $class, $obj->cpanid, $obj->author, $obj->email;
+ }
+ print scalar(@$aref)." items found\n" unless $short;
+ }
+
+ return $aref;
+}
+
+sub _pp_module {
+ my $self = shift;
+ my %hash = @_;
+
+ my( $aref, $short, $class, $input );
+ my $tmpl = {
+ result => { required => 1, default => [], strict_type => 1,
+ store => \$aref },
+ short => { default => 0, store => \$short },
+ class => { required => 1, store => \$class },
+ input => { required => 1, store => \$input },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+
+ ### no results
+ if( !@$aref ) {
+ print "No objects of type $class found for argument $input\n"
+ unless $short;
+
+ ### one result, long output desired;
+ } elsif( @$aref == 1 and !$short ) {
+
+
+ ### should look like this:
+ #Module id = LWP
+ # DESCRIPTION Libwww-perl
+ # CPAN_USERID GAAS (Gisle Aas <gisle@ActiveState.com>)
+ # CPAN_VERSION 5.64
+ # CPAN_FILE G/GA/GAAS/libwww-perl-5.64.tar.gz
+ # DSLI_STATUS RmpO (released,mailing-list,perl,object-oriented)
+ # MANPAGE LWP - The World-Wide Web library for Perl
+ # INST_FILE C:\Perl\site\lib\LWP.pm
+ # INST_VERSION 5.62
+
+ my $obj = shift @$aref;
+ my $aut_obj = $obj->author;
+ my $format = " %-12s %s%s\n";
+
+ print "$class id = ", $obj->module(), "\n";
+ printf $format, 'DESCRIPTION', $obj->description()
+ if $obj->description();
+
+ printf $format, 'CPAN_USERID', $aut_obj->cpanid() . " (" .
+ $aut_obj->author() . " <" . $aut_obj->email() . ">)";
+
+ printf $format, 'CPAN_VERSION', $obj->version();
+ printf $format, 'CPAN_FILE', $obj->path() . '/' . $obj->package();
+
+ printf $format, 'DSLI_STATUS', $self->_pp_dslip($obj->dslip)
+ if $obj->dslip() =~ /\w/;
+
+ #printf $format, 'MANPAGE', $obj->foo();
+ ### this is for bundles... CPAN.pm downloads them,
+ #printf $format, 'CONATAINS,
+ # parses and goes from there...
+
+ printf $format, 'INST_FILE', $obj->installed_file ||
+ '(not installed)';
+ printf $format, 'INST_VERSION', $obj->installed_version;
+
+
+
+ } else {
+
+ ### should look like this:
+ #Module LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz)
+ #Module POE (R/RC/RCAPUTO/POE-0.19.tar.gz)
+ #2 items found
+
+ for my $obj ( @$aref ) {
+ printf "%-15s %-15s (%s)\n", $class, $obj->module(),
+ $obj->path() .'/'. $obj->package();
+ }
+ print scalar(@$aref). " items found\n" unless $short;
+ }
+
+ return $aref;
+}
+
+sub _pp_dslip {
+ my $self = shift;
+ my $dslip = shift or return;
+
+ my (%_statusD, %_statusS, %_statusL, %_statusI);
+
+ @_statusD{qw(? i c a b R M S)} =
+ qw(unknown idea pre-alpha alpha beta released mature standard);
+
+ @_statusS{qw(? m d u n)} =
+ qw(unknown mailing-list developer comp.lang.perl.* none);
+
+ @_statusL{qw(? p c + o h)} = qw(unknown perl C C++ other hybrid);
+ @_statusI{qw(? f r O h)} =
+ qw(unknown functions references+ties object-oriented hybrid);
+
+ my @status = split("", $dslip);
+
+ my $results = sprintf( "%s (%s,%s,%s,%s)",
+ $dslip,
+ $_statusD{$status[0]},
+ $_statusS{$status[1]},
+ $_statusL{$status[2]},
+ $_statusI{$status[3]}
+ );
+
+ return $results;
+}
+
+sub _pp_distribution {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my( $aref, $short, $class, $input );
+ my $tmpl = {
+ result => { required => 1, default => [], strict_type => 1,
+ store => \$aref },
+ short => { default => 0, store => \$short },
+ class => { required => 1, store => \$class },
+ input => { required => 1, store => \$input },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+
+ ### no results
+ if( !@$aref ) {
+ print "No objects of type $class found for argument $input\n"
+ unless $short;
+
+ ### one result, long output desired;
+ } elsif( @$aref == 1 and !$short ) {
+
+
+ ### should look like this:
+ #Distribution id = S/SA/SABECK/POE-Component-Client-POP3-0.02.tar.gz
+ # CPAN_USERID SABECK (Scott Beck <scott@gossamer-threads.com>)
+ # CONTAINSMODS POE::Component::Client::POP3
+
+ my $obj = shift @$aref;
+ my $aut_obj = $obj->author;
+ my $pkg = $obj->package;
+ my $format = " %-12s %s\n";
+
+ my @list = $cb->search( type => 'package',
+ allow => [qr/^$pkg$/] );
+
+
+ print "$class id = ", $obj->path(), '/', $obj->package(), "\n";
+ printf $format, 'CPAN_USERID',
+ $aut_obj->cpanid .' ('. $aut_obj->author .
+ ' '. $aut_obj->email .')';
+
+ ### yes i know it's ugly, but it's what cpan.pm does
+ printf $format, 'CONTAINSMODS', join (' ', map { $_->module } @list);
+
+ } else {
+
+ ### should look like this:
+ #Distribution LWP (G/GA/GAAS/libwww-perl-5.64.tar.gz)
+ #Distribution POE (R/RC/RCAPUTO/POE-0.19.tar.gz)
+ #2 items found
+
+ for my $obj ( @$aref ) {
+ printf "%-15s %s\n", $class, $obj->path() .'/'. $obj->package();
+ }
+
+ print scalar(@$aref). " items found\n" unless $short;
+ }
+
+ return $aref;
+}
+
+sub _pp_uptodate {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my( $aref, $short, $class, $input );
+ my $tmpl = {
+ result => { required => 1, default => [], strict_type => 1,
+ store => \$aref },
+ short => { default => 0, store => \$short },
+ class => { required => 1, store => \$class },
+ input => { required => 1, store => \$input },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my $format = "%-25s %9s %9s %s\n";
+
+ my @not_uptodate;
+ my $no_version;
+
+ my %seen;
+ for my $mod (@$aref) {
+ next if $mod->package_is_perl_core;
+ next if $seen{ $mod->package }++;
+
+
+ if( $mod->installed_file and not $mod->installed_version ) {
+ $no_version++;
+ next;
+ }
+
+ push @not_uptodate, $mod unless $mod->is_uptodate;
+ }
+
+ unless( @not_uptodate ) {
+ my $string = $input
+ ? "for $input"
+ : '';
+ print "All modules are up to date $string\n";
+ return;
+
+ } else {
+ printf $format, ( 'Package namespace',
+ 'installed',
+ 'latest',
+ 'in CPAN file'
+ );
+ }
+
+ for my $mod ( sort { $a->module cmp $b->module } @not_uptodate ) {
+ printf $format, ( $mod->module,
+ $mod->installed_version,
+ $mod->version,
+ $mod->path .'/'. $mod->package,
+ );
+ }
+
+ print "$no_version installed modules have no (parsable) version number\n"
+ if $no_version;
+
+ return \@not_uptodate;
+}
+
+sub _pp_ls {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my( $aref, $short, $class, $input );
+ my $tmpl = {
+ result => { required => 1, default => [], strict_type => 1,
+ store => \$aref },
+ short => { default => 0, store => \$short },
+ class => { required => 1, store => \$class },
+ input => { required => 1, store => \$input },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### should look something like this:
+ #6272 2002-05-12 KANE/Acme-Comment-1.00.tar.gz
+ #8171 2002-08-13 KANE/Acme-Comment-1.01.zip
+ #7110 2002-09-04 KANE/Acme-Comment-1.02.tar.gz
+ #7571 2002-09-08 KANE/Acme-Intraweb-1.01.tar.gz
+ #6625 2001-08-23 KANE/Acme-POE-Knee-1.10.zip
+ #3058 2003-10-05 KANE/Acme-Test-0.02.tar.gz
+
+ ### don't know size or mtime
+ #my $format = "%8d %10s %s/%s\n";
+
+ for my $mod ( sort { $a->package cmp $b->package } @$aref ) {
+ print "\t" . $mod->package . "\n";
+ }
+
+ return $aref;
+}
+
+
+#############################
+### end pretty print subs ###
+#############################
+
+
+sub _bang {
+ my $self = shift;
+ my %hash = @_;
+
+ my( $input );
+ my $tmpl = {
+ input => { required => 1, store => \$input },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ eval $input;
+ warn $@ if $@;
+
+ print "\n";
+
+ return;
+}
+
+sub _help {
+ print qq[
+Display Information
+ a authors
+ b string display bundles
+ d or info distributions
+ m /regex/ about modules
+ i or anything of above
+ r none reinstall recommendations
+ u uninstalled distributions
+
+Download, Test, Make, Install...
+ get download
+ make make (implies get)
+ test modules, make test (implies make)
+ install dists, bundles make install (implies test)
+ clean make clean
+ look open subshell in these dists' directories
+ readme display these dists' README files
+
+Other
+ h,? display this menu ! perl-code eval a perl command
+ o conf [opt] set and query options q quit the cpan shell
+ reload cpan load CPAN.pm again reload index load newer indices
+ autobundle Snapshot force cmd unconditionally do cmd
+];
+
+}
+
+
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Shell::Classic - CPAN.pm emulation for CPANPLUS
+
+=head1 DESCRIPTION
+
+The Classic shell is designed to provide the feel of the CPAN.pm shell
+using CPANPLUS underneath.
+
+For detailed documentation, refer to L<CPAN>.
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>
+
+=cut
+
+
+=head1 SEE ALSO
+
+L<CPAN>
+
+=cut
+
+
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm
new file mode 100644
index 00000000000..a9d51422f66
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default.pm
@@ -0,0 +1,1938 @@
+package CPANPLUS::Shell::Default;
+
+use strict;
+
+
+use CPANPLUS::Error;
+use CPANPLUS::Backend;
+use CPANPLUS::Configure::Setup;
+use CPANPLUS::Internals::Constants;
+use CPANPLUS::Internals::Constants::Report qw[GRADE_FAIL];
+
+use Cwd;
+use IPC::Cmd;
+use Term::UI;
+use Data::Dumper;
+use Term::ReadLine;
+
+use Module::Load qw[load];
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load check_install];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+local $Params::Check::VERBOSE = 1;
+local $Data::Dumper::Indent = 1; # for dumpering from !
+
+BEGIN {
+ use vars qw[ $VERSION @ISA ];
+ @ISA = qw[ CPANPLUS::Shell::_Base::ReadLine ];
+ $VERSION = "0.90";
+}
+
+load CPANPLUS::Shell;
+
+
+my $map = {
+ 'm' => '_search_module',
+ 'a' => '_search_author',
+ '!' => '_bang',
+ '?' => '_help',
+ 'h' => '_help',
+ 'q' => '_quit',
+ 'r' => '_readme',
+ 'v' => '_show_banner',
+ 'w' => '__display_results',
+ 'd' => '_fetch',
+ 'z' => '_shell',
+ 'f' => '_distributions',
+ 'x' => '_reload_indices',
+ 'i' => '_install',
+ 't' => '_install',
+ 'l' => '_details',
+ 'p' => '_print',
+ 's' => '_set_conf',
+ 'o' => '_uptodate',
+ 'b' => '_autobundle',
+ 'u' => '_uninstall',
+ '/' => '_meta', # undocumented for now
+ 'c' => '_reports',
+};
+### free letters: e g j k n y ###
+
+
+### will be filled if you have a .default-shell.rc and
+### Config::Auto installed
+my $rc = {};
+
+### the shell object, scoped to the file ###
+my $Shell;
+my $Brand = loc('CPAN Terminal');
+my $Prompt = $Brand . '> ';
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Shell::Default
+
+=head1 SYNOPSIS
+
+ ### loading the shell:
+ $ cpanp # run 'cpanp' from the command line
+ $ perl -MCPANPLUS -eshell # load the shell from the command line
+
+
+ use CPANPLUS::Shell qw[Default]; # load this shell via the API
+ # always done via CPANPLUS::Shell
+
+ my $ui = CPANPLUS::Shell->new;
+ $ui->shell; # run the shell
+ $ui->dispatch_on_input( input => 'x'); # update the source using the
+ # dispatch method
+
+ ### when in the shell:
+ ### Note that all commands can also take options.
+ ### Look at their underlying CPANPLUS::Backend methods to see
+ ### what options those are.
+ cpanp> h # show help messages
+ cpanp> ? # show help messages
+
+ cpanp> m Acme # find acme modules, allows regexes
+ cpanp> a KANE # find modules by kane, allows regexes
+ cpanp> f Acme::Foo # get a list of all releases of Acme::Foo
+
+ cpanp> i Acme::Foo # install Acme::Foo
+ cpanp> i Acme-Foo-1.3 # install version 1.3 of Acme::Foo
+ cpanp> i <URI> # install from URI, like ftp://foo.com/X.tgz
+ cpanp> i <DIR> # install from an absolute or relative directory
+ cpanp> i 1 3..5 # install search results 1, 3, 4 and 5
+ cpanp> i * # install all search results
+ cpanp> a KANE; i *; # find modules by kane, install all results
+ cpanp> t Acme::Foo # test Acme::Foo, without installing it
+ cpanp> u Acme::Foo # uninstall Acme::Foo
+ cpanp> d Acme::Foo # download Acme::Foo
+ cpanp> z Acme::Foo # download & extract Acme::Foo, then open a
+ # shell in the extraction directory
+
+ cpanp> c Acme::Foo # get a list of test results for Acme::Foo
+ cpanp> l Acme::Foo # view details about the Acme::Foo package
+ cpanp> r Acme::Foo # view Acme::Foo's README file
+ cpanp> o # get a list of all installed modules that
+ # are out of date
+ cpanp> o 1..3 # list uptodateness from a previous search
+
+ cpanp> s conf # show config settings
+ cpanp> s conf md5 1 # enable md5 checks
+ cpanp> s program # show program settings
+ cpanp> s edit # edit config file
+ cpanp> s reconfigure # go through initial configuration again
+ cpanp> s selfupdate # update your CPANPLUS install
+ cpanp> s save # save config to disk
+ cpanp> s mirrors # show currently selected mirrors
+
+ cpanp> ! [PERL CODE] # execute the following perl code
+
+ cpanp> b # create an autobundle for this computers
+ # perl installation
+ cpanp> x # reload index files (purges cache)
+ cpanp> x --update_source # reload index files, get fresh source files
+ cpanp> p [FILE] # print error stack (to a file)
+ cpanp> v # show the banner
+ cpanp> w # show last search results again
+
+ cpanp> q # quit the shell
+
+ cpanp> /plugins # list avialable plugins
+ cpanp> /? PLUGIN # list help test of <PLUGIN>
+
+ ### common options:
+ cpanp> i ... --skiptest # skip tests
+ cpanp> i ... --force # force all operations
+ cpanp> i ... --verbose # run in verbose mode
+
+=head1 DESCRIPTION
+
+This module provides the default user interface to C<CPANPLUS>. You
+can start it via the C<cpanp> binary, or as detailed in the L<SYNOPSIS>.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ my $cb = CPANPLUS::Backend->new( @_ );
+ my $self = $class->SUPER::_init(
+ brand => $Brand,
+ term => Term::ReadLine->new( $Brand ),
+ prompt => $Prompt,
+ backend => $cb,
+ format => "%4s %-55s %8s %-10s\n",
+ dist_format => "%4s %-42s %-12s %8s %-10s\n",
+ );
+ ### make it available package wide ###
+ $Shell = $self;
+
+ my $rc_file = File::Spec->catfile(
+ $cb->configure_object->get_conf('base'),
+ DOT_SHELL_DEFAULT_RC,
+ );
+
+
+ if( -e $rc_file && -r _ ) {
+ $rc = $self->_read_configuration_from_rc( $rc_file );
+ }
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'install_prerequisite',
+ code => \&__ask_about_install,
+ );
+
+ ### execute any login commands specified ###
+ $self->dispatch_on_input( input => $rc->{'login'} )
+ if defined $rc->{'login'};
+
+ ### register test report callbacks ###
+ $cb->_register_callback(
+ name => 'edit_test_report',
+ code => \&__ask_about_edit_test_report,
+ );
+
+ $cb->_register_callback(
+ name => 'send_test_report',
+ code => \&__ask_about_send_test_report,
+ );
+
+ $cb->_register_callback(
+ name => 'proceed_on_test_failure',
+ code => \&__ask_about_test_failure,
+ );
+
+ ### load all the plugins
+ $self->_plugins_init;
+
+ return $self;
+}
+
+sub shell {
+ my $self = shift;
+ my $term = $self->term;
+ my $conf = $self->backend->configure_object;
+
+ $self->_show_banner;
+ $self->__print( "*** Type 'p' now to show start up log\n" ); # XXX add to banner?
+ $self->_show_random_tip if $conf->get_conf('show_startup_tip');
+ $self->_input_loop && $self->__print( "\n" );
+ $self->_quit;
+}
+
+sub _input_loop {
+ my $self = shift;
+ my $term = $self->term;
+ my $cb = $self->backend;
+
+ my $normal_quit = 0;
+ while (
+ defined (my $input = eval { $term->readline($self->prompt) } )
+ or $self->_signals->{INT}{count} == 1
+ ) {
+ ### re-initiate all signal handlers
+ while (my ($sig, $entry) = each %{$self->_signals} ) {
+ $SIG{$sig} = $entry->{handler} if exists($entry->{handler});
+ }
+
+ $self->__print( "\n" );
+ last if $self->dispatch_on_input( input => $input );
+
+ ### flush the lib cache ###
+ $cb->_flush( list => [qw|lib load|] );
+
+ } continue {
+ ### clear the sigint count
+ $self->_signals->{INT}{count}--
+ if $self->_signals->{INT}{count};
+
+ ### reset the 'install prereq?' cached answer
+ $self->settings->{'install_all_prereqs'} = undef;
+
+ }
+
+ return 1;
+}
+
+### return 1 to quit ###
+sub dispatch_on_input {
+ my $self = shift;
+ my $conf = $self->backend->configure_object();
+ my $term = $self->term;
+ my %hash = @_;
+
+ my($string, $noninteractive);
+ my $tmpl = {
+ input => { required => 1, store => \$string },
+ noninteractive => { required => 0, store => \$noninteractive },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### indicates whether or not the user will receive a shell
+ ### prompt after the command has finished.
+ $self->noninteractive($noninteractive) if defined $noninteractive;
+
+ my $rv = 1;
+
+ my @cmds = split ';', $string;
+ while( my $input = shift @cmds ) {
+
+ ### to send over the socket ###
+ my $org_input = $input;
+
+ my $key; my $options;
+ { ### make whitespace not count when using special chars
+ { $input =~ s|^\s*([!?/])|$1 |; }
+
+ ### get the first letter of the input
+ $input =~ s|^\s*([\w\?\!/])\w*||;
+
+ chomp $input;
+ $key = lc($1);
+
+ ### we figured out what the command was...
+ ### if we have more input, that DOES NOT start with a white
+ ### space char, we misparsed.. like 'Test::Foo::Bar', which
+ ### would turn into 't', '::Foo::Bar'...
+ if( $input and $input !~ s/^\s+// ) {
+ $self->__print( loc("Could not understand command: %1\n".
+ "Possibly missing command before argument(s)?\n",
+ $org_input) );
+ return;
+ }
+
+ ### allow overrides from the config file ###
+ if( defined $rc->{$key} ) {
+ $input = $rc->{$key} . $input;
+ }
+
+ ### grab command line options like --no-force and --verbose ###
+ ($options,$input) = $term->parse_options($input)
+ unless $key eq '!';
+ }
+
+ ### emtpy line? ###
+ return unless $key;
+
+ ### time to quit ###
+ return 1 if $key eq 'q';
+
+ my $method = $map->{$key};
+
+ ### dispatch meta locally at all times ###
+ if( $key eq '/' ) {
+ ### keep track of failures
+ $rv *= length $self->$method(input => $input, options => $options);
+ next;
+ }
+
+ ### flush unless we're trying to print the stack
+ CPANPLUS::Error->flush unless $key eq 'p';
+
+ ### connected over a socket? ###
+ if( $self->remote ) {
+
+ ### unsupported commands ###
+ if( $key eq 'z' or
+ ($key eq 's' and $input =~ /^\s*edit/)
+ ) {
+ $self->__print( "\n",
+ loc( "Command '%1' not supported over remote connection",
+ join ' ', $key, $input
+ ), "\n\n" );
+
+ } else {
+ my($status,$buff) = $self->__send_remote_command($org_input);
+
+ $self->__print( "\n", loc("Command failed!"), "\n\n" )
+ unless $status;
+
+ ### keep track of failures
+ $rv *= length $status;
+
+ $self->_pager_open if $buff =~ tr/\n// > $self->_term_rowcount;
+ $self->__print( $buff );
+ $self->_pager_close;
+ }
+
+ ### or just a plain local shell? ###
+ } else {
+
+ unless( $self->can($method) ) {
+ $self->__print(loc("Unknown command '%1'. Usage:", $key), "\n");
+ $self->_help;
+
+ } else {
+
+ ### some methods don't need modules ###
+ my @mods;
+ @mods = $self->_select_modules($input)
+ unless grep {$key eq $_} qw[! m a v w x p s b / ? h];
+
+ ### keep track of failures
+ $rv *= defined eval { $self->$method(
+ modules => \@mods,
+ options => $options,
+ input => $input,
+ choice => $key )
+ };
+ error( $@ ) if $@;
+ }
+ }
+ }
+
+ ### outside the shell loop, we can return the actual return value;
+ return $rv if $self->noninteractive;
+
+ return;
+}
+
+sub _select_modules {
+ my $self = shift;
+ my $input = shift or return;
+ my $cache = $self->cache;
+ my $cb = $self->backend;
+
+ ### expand .. in $input
+ $input =~ s{\b(\d+)\s*\.\.\s*(\d+)\b}
+ {join(' ', ($1 < 1 ? 1 : $1) .. ($2 > $#{$cache} ? $#{$cache} : $2))}eg;
+
+ $input = join(' ', 1 .. $#{$cache}) if $input eq '*';
+ $input =~ s/'/::/g; # perl 4 convention
+
+ my @rv;
+ for my $mod (split /\s+/, $input) {
+
+ ### it's a cache look up ###
+ if( $mod =~ /^\d+/ and $mod > 0 ) {
+ unless( scalar @$cache ) {
+ $self->__print( loc("No search was done yet!"), "\n" );
+
+ } elsif ( my $obj = $cache->[$mod] ) {
+ push @rv, $obj;
+
+ } else {
+ $self->__print( loc("No such module: %1", $mod), "\n" );
+ }
+
+ } else {
+ my $obj = $cb->parse_module( module => $mod );
+
+ unless( $obj ) {
+ $self->__print( loc("No such module: %1", $mod), "\n" );
+
+ } else {
+ push @rv, $obj;
+ }
+ }
+ }
+
+ unless( scalar @rv ) {
+ $self->__print( loc("No modules found to operate on!\n") );
+ return;
+ } else {
+ return @rv;
+ }
+}
+
+sub _format_version {
+ my $self = shift;
+ my $version = shift || 0;
+
+ ### fudge $version into the 'optimal' format
+ $version = 0 if $version eq 'undef';
+ $version =~ s/_//g; # everything after gets stripped off otherwise
+
+ ### allow 6 digits after the dot, as that's how perl stringifies
+ ### x.y.z numbers.
+ $version = sprintf('%3.6f', $version);
+ $version = '' if $version == '0.00';
+ $version =~ s/(00{0,3})$/' ' x (length $1)/e;
+
+ return $version;
+}
+
+sub __display_results {
+ my $self = shift;
+ my $cache = $self->cache;
+
+ my @rv = @$cache;
+
+ if( scalar @rv ) {
+
+ $self->_pager_open if $#{$cache} >= $self->_term_rowcount;
+
+ my $i = 1;
+ for my $mod (@rv) {
+ next unless $mod; # first one is undef
+ # humans start counting at 1
+
+ ### for dists only -- we have checksum info
+ if( $mod->mtime ) {
+ $self->__printf(
+ $self->dist_format,
+ $i,
+ $mod->module,
+ $mod->mtime,
+ $self->_format_version( $mod->version ),
+ $mod->author->cpanid
+ );
+
+ } else {
+ $self->__printf(
+ $self->format,
+ $i,
+ $mod->module,
+ $self->_format_version( $mod->version ),
+ $mod->author->cpanid
+ );
+ }
+ $i++;
+ }
+
+ $self->_pager_close;
+
+ } else {
+ $self->__print( loc("No results to display"), "\n" );
+ }
+
+ return 1;
+}
+
+
+sub _quit {
+ my $self = shift;
+
+ $self->dispatch_on_input( input => $rc->{'logout'} )
+ if defined $rc->{'logout'};
+
+ $self->__print( loc("Exiting CPANPLUS shell"), "\n" );
+
+ return 1;
+}
+
+###########################
+### actual command subs ###
+###########################
+
+
+### print out the help message ###
+### perhaps, '?' should be a slightly different version ###
+{ my @help;
+ sub _help {
+ my $self = shift;
+ my %hash = @_;
+
+ my $input;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ input => { required => 0, store => \$input }
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+ }
+
+ @help = (
+loc('[General]' ),
+loc(' h | ? # display help' ),
+loc(' q # exit' ),
+loc(' v # version information' ),
+loc('[Search]' ),
+loc(' a AUTHOR ... # search by author(s)' ),
+loc(' m MODULE ... # search by module(s)' ),
+loc(' f MODULE ... # list all releases of a module' ),
+loc(" o [ MODULE ... ] # list installed module(s) that aren't up to date" ),
+loc(' w # display the result of your last search again' ),
+loc('[Operations]' ),
+loc(' i MODULE | NUMBER ... # install module(s), by name or by search number' ),
+loc(' i URI | ... # install module(s), by URI (ie http://foo.com/X.tgz)' ),
+loc(' i DIR | ... # install module(s), by path (ie ./Module-1.0)' ),
+loc(' t MODULE | NUMBER ... # test module(s), by name or by search number' ),
+loc(' u MODULE | NUMBER ... # uninstall module(s), by name or by search number' ),
+loc(' d MODULE | NUMBER ... # download module(s)' ),
+loc(' l MODULE | NUMBER ... # display detailed information about module(s)' ),
+loc(' r MODULE | NUMBER ... # display README files of module(s)' ),
+loc(' c MODULE | NUMBER ... # check for module report(s) from cpan-testers' ),
+loc(' z MODULE | NUMBER ... # extract module(s) and open command prompt in it' ),
+loc('[Local Administration]' ),
+loc(' b # write a bundle file for your configuration' ),
+loc(' s program [OPT VALUE] # set program locations for this session' ),
+loc(' s conf [OPT VALUE] # set config options for this session' ),
+loc(' s mirrors # show currently selected mirrors' ),
+loc(' s reconfigure # reconfigure settings ' ),
+loc(' s selfupdate # update your CPANPLUS install '),
+loc(' s save [user|system] # save settings for this user or systemwide' ),
+loc(' s edit [user|system] # open configuration file in editor and reload' ),
+loc(' ! EXPR # evaluate a perl statement' ),
+loc(' p [FILE] # print the error stack (optionally to a file)' ),
+loc(' x # reload CPAN indices (purges cache)' ),
+loc(' x --update_source # reload CPAN indices, get fresh source files' ),
+loc('[Common Options]' ),
+loc(' i ... --skiptest # skip tests' ),
+loc(' i ... --force # force all operations' ),
+loc(' i ... --verbose # run in verbose mode' ),
+loc('[Plugins]' ),
+loc(' /plugins # list available plugins' ),
+loc(' /? [PLUGIN NAME] # show usage for (a particular) plugin(s)' ),
+
+ ) unless @help;
+
+ $self->_pager_open if (@help >= $self->_term_rowcount);
+ ### XXX: functional placeholder for actual 'detailed' help.
+ $self->__print( "Detailed help for the command '$input' is " .
+ "not available.\n\n" ) if length $input;
+ $self->__print( map {"$_\n"} @help );
+ $self->__print( $/ );
+ $self->_pager_close;
+
+ return 1;
+ }
+}
+
+### eval some code ###
+sub _bang {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+
+ my $input;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ input => { required => 1, store => \$input }
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+ }
+
+ local $Data::Dumper::Indent = 1; # for dumpering from !
+ eval $input;
+ error( $@ ) if $@;
+ $self->__print( "\n" );
+
+ return if $@;
+ return 1;
+}
+
+sub _search_module {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my $args;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ input => { required => 1, },
+ options => { default => { } },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'};
+
+ ### XXX this is rather slow, because (probably)
+ ### of the many method calls
+ ### XXX need to profile to speed it up =/
+
+ ### find the modules ###
+ my @rv = sort { $a->module cmp $b->module }
+ $cb->search(
+ %{$args->{'options'}},
+ type => 'module',
+ allow => \@regexes,
+ );
+
+ ### store the result in the cache ###
+ $self->cache([undef,@rv]);
+
+ $self->__display_results;
+
+ return 1;
+}
+
+sub _search_author {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my $args;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ input => { required => 1, },
+ options => { default => { } },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ my @regexes = map { qr/$_/i } split /\s+/, $args->{'input'};
+
+ my @rv;
+ for my $type (qw[author cpanid]) {
+ push @rv, $cb->search(
+ %{$args->{'options'}},
+ type => $type,
+ allow => \@regexes,
+ );
+ }
+
+ my %seen;
+ my @list = sort { $a->module cmp $b->module }
+ grep { defined }
+ map { $_->modules }
+ grep { not $seen{$_}++ } @rv;
+
+ $self->cache([undef,@list]);
+
+ $self->__display_results;
+ return 1;
+}
+
+sub _readme {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my $args; my $mods; my $opts;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ modules => { required => 1, store => \$mods },
+ options => { default => { }, store => \$opts },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ return unless scalar @$mods;
+
+ $self->_pager_open;
+ for my $mod ( @$mods ) {
+ $self->__print( $mod->readme( %$opts ) );
+ }
+
+ $self->_pager_close;
+
+ return 1;
+}
+
+sub _fetch {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my $args; my $mods; my $opts;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ modules => { required => 1, store => \$mods },
+ options => { default => { }, store => \$opts },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ $self->_pager_open if @$mods >= $self->_term_rowcount;
+ my $rv = 1;
+ for my $mod (@$mods) {
+ my $where = $mod->fetch( %$opts );
+
+ $rv *= length $where;
+
+ $self->__print(
+ $where
+ ? loc("Successfully fetched '%1' to '%2'",
+ $mod->module, $where )
+ : loc("Failed to fetch '%1'", $mod->module)
+ );
+ $self->__print( "\n" );
+ }
+ $self->_pager_close;
+
+ return 1 if $rv;
+ return;
+}
+
+sub _shell {
+ my $self = shift;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my $shell = $conf->get_program('shell');
+ unless( $shell ) {
+ $self->__print(
+ loc("Your config does not specify a subshell!"), "\n",
+ loc("Perhaps you need to re-run your setup?"), "\n"
+ );
+ return;
+ }
+
+ my $args; my $mods; my $opts;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ modules => { required => 1, store => \$mods },
+ options => { default => { }, store => \$opts },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ my $cwd = Cwd::cwd();
+ for my $mod (@$mods) {
+ $mod->fetch( %$opts ) or next;
+ $mod->extract( %$opts ) or next;
+
+ $cb->_chdir( dir => $mod->status->extract() ) or next;
+
+ #local $ENV{PERL5OPT} = CPANPLUS::inc->original_perl5opt;
+
+ if( system($shell) and $! ) {
+ $self->__print(
+ loc("Error executing your subshell '%1': %2",
+ $shell, $!),"\n"
+ );
+ next;
+ }
+ }
+ $cb->_chdir( dir => $cwd );
+
+ return 1;
+}
+
+sub _distributions {
+ my $self = shift;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my $args; my $mods; my $opts;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ modules => { required => 1, store => \$mods },
+ options => { default => { }, store => \$opts },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ my @list;
+ for my $mod (@$mods) {
+ push @list, sort { $a->version <=> $b->version }
+ grep { defined } $mod->distributions( %$opts );
+ }
+
+ my @rv = sort { $a->module cmp $b->module } @list;
+
+ $self->cache([undef,@rv]);
+ $self->__display_results;
+
+ return 1;
+}
+
+sub _reload_indices {
+ my $self = shift;
+ my $cb = $self->backend;
+ my %hash = @_;
+
+ my $args; my $opts;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ options => { default => { }, store => \$opts },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ my $rv = $cb->reload_indices( %$opts );
+
+ ### so the update failed, but you didnt give it any options either
+ if( !$rv and !(keys %$opts) ) {
+ $self->__print(
+ "\nFailure may be due to corrupt source files\n" .
+ "Try this:\n\tx --update_source\n\n" );
+ }
+
+ return $rv;
+
+}
+
+sub _install {
+ my $self = shift;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my $args; my $mods; my $opts; my $choice;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ modules => { required => 1, store => \$mods },
+ options => { default => { }, store => \$opts },
+ choice => { required => 1, store => \$choice,
+ allow => [qw|i t|] },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ unless( scalar @$mods ) {
+ $self->__print( loc("Nothing done\n") );
+ return;
+ }
+
+ my $target = $choice eq 'i' ? TARGET_INSTALL : TARGET_CREATE;
+ my $prompt = $choice eq 'i' ? loc('Installing ') : loc('Testing ');
+ my $action = $choice eq 'i' ? 'install' : 'test';
+
+ my $status = {};
+ ### first loop over the mods to install them ###
+ for my $mod (@$mods) {
+ $self->__print( $prompt, $mod->module, " (".$mod->version.")", "\n" );
+
+ my $log_length = length CPANPLUS::Error->stack_as_string;
+
+ ### store the status for look up when we're done with all
+ ### install calls
+ $status->{$mod} = $mod->install( %$opts, target => $target );
+
+ ### would you like a log file of what happened?
+ if( $conf->get_conf('write_install_logs') ) {
+
+ if ( ON_WIN32 and !check_install(
+ module => 'IPC::Run', version => 0.55 )
+ ) {
+ error(loc("IPC::Run version '%1' is required on MSWin32"
+ . " in order to capture buffers."
+ . " The logfile generated may not contain"
+ . " any useful data, until it is installed", 0.55));
+ }
+
+ my $dir = File::Spec->catdir(
+ $conf->get_conf('base'),
+ $conf->_get_build('install_log_dir'),
+ );
+ ### create the dir if it doesn't exit yet
+ $cb->_mkdir( dir => $dir ) unless -d $dir;
+
+ my $file = File::Spec->catfile(
+ $dir,
+ INSTALL_LOG_FILE->( $mod )
+ );
+ if ( open my $fh, ">$file" ) {
+ my $stack = CPANPLUS::Error->stack_as_string;
+ ### remove everything in the log that was there *before*
+ ### we started this install
+ substr( $stack, 0, $log_length, '' );
+
+ print $fh $stack;
+ close $fh;
+
+ $self->__print(
+ loc("*** Install log written to:\n %1\n\n", $file)
+ );
+ } else {
+ warn "Could not open '$file': $!\n";
+ next;
+ }
+ }
+ }
+
+ my $flag;
+ ### then report whether all this went ok or not ###
+ for my $mod (@$mods) {
+ # if( $mod->status->installed ) {
+ if( $status->{$mod} ) {
+ $self->__print(
+ loc("Module '%1' %tense(%2,past) successfully\n",
+ $mod->module, $action)
+ );
+ } else {
+ $flag++;
+ $self->__print(
+ loc("Error %tense(%1,present) '%2'\n", $action, $mod->module)
+ );
+ }
+ }
+
+
+
+ if( !$flag ) {
+ $self->__print(
+ loc("No errors %tense(%1,present) all modules", $action), "\n"
+ );
+ } else {
+ $self->__print(
+ loc("Problem %tense(%1,present) one or more modules", $action)
+ );
+ $self->__print( "\n" );
+
+ $self->__print(
+ loc("*** You can view the complete error buffer by pressing ".
+ "'%1' ***\n", 'p')
+ ) unless $conf->get_conf('verbose') || $self->noninteractive;
+ }
+ $self->__print( "\n" );
+
+ return !$flag;
+}
+
+sub __ask_about_install {
+ my $mod = shift or return;
+ my $prereq = shift or return;
+ my $term = $Shell->term;
+
+ $Shell->__print( "\n" );
+ $Shell->__print( loc("Module '%1' requires '%2' to be installed",
+ $mod->module, $prereq->module ) );
+ $Shell->__print( "\n\n" );
+
+ ### previously cached answer?
+ return $Shell->settings->{'install_all_prereqs'}
+ if defined $Shell->settings->{'install_all_prereqs'};
+
+
+ $Shell->__print(
+ loc( "If you don't wish to see this question anymore\n".
+ "you can disable it by entering the following ".
+ "commands on the prompt:\n '%1'",
+ 's conf prereqs 1; s save' ) );
+ $Shell->__print("\n\n");
+
+ my $yes = loc("Yes");
+ my $no = loc("No");
+ my $all = loc("Yes to all (for this module)");
+ my $none = loc("No to all (for this module)");
+
+ my $reply = $term->get_reply(
+ prompt => loc("Should I install this module?"),
+ choices => [ $yes, $no, $all, $none ],
+ default => $yes,
+ );
+
+ ### if 'all' or 'none', save this, so we can apply it to
+ ### other prereqs in this chain.
+ $Shell->settings->{'install_all_prereqs'} =
+ $reply eq $all ? 1 :
+ $reply eq $none ? 0 :
+ undef;
+
+ ### if 'yes' or 'all', the user wants it installed
+ return $reply eq $all ? 1 :
+ $reply eq $yes ? 1 :
+ 0;
+}
+
+sub __ask_about_send_test_report {
+ my($mod, $grade) = @_;
+ return 1 unless $grade eq GRADE_FAIL;
+
+ my $term = $Shell->term;
+
+ $Shell->__print( "\n" );
+ $Shell->__print(
+ loc("Test report prepared for module '%1'.\n Would you like to ".
+ "send it? (You can edit it if you like)", $mod->module ) );
+ $Shell->__print( "\n\n" );
+ my $bool = $term->ask_yn(
+ prompt => loc("Would you like to send the test report?"),
+ default => 'n'
+ );
+
+ return $bool;
+}
+
+sub __ask_about_edit_test_report {
+ my($mod, $grade) = @_;
+ return 0 unless $grade eq GRADE_FAIL;
+
+ my $term = $Shell->term;
+
+ $Shell->__print( "\n" );
+ $Shell->__print(
+ loc("Test report prepared for module '%1'. You can edit this ".
+ "report if you would like", $mod->module ) );
+ $Shell->__print("\n\n");
+ my $bool = $term->ask_yn(
+ prompt => loc("Would you like to edit the test report?"),
+ default => 'y'
+ );
+
+ return $bool;
+}
+
+sub __ask_about_test_failure {
+ my $mod = shift;
+ my $captured = shift || '';
+ my $term = $Shell->term;
+
+ $Shell->__print( "\n" );
+ $Shell->__print(
+ loc( "The tests for '%1' failed. Would you like me to proceed ".
+ "anyway or should we abort?", $mod->module ) );
+ $Shell->__print( "\n\n" );
+
+ my $bool = $term->ask_yn(
+ prompt => loc("Proceed anyway?"),
+ default => 'n',
+ );
+
+ return $bool;
+}
+
+
+sub _details {
+ my $self = shift;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+ my %hash = @_;
+
+ my $args; my $mods; my $opts;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ modules => { required => 1, store => \$mods },
+ options => { default => { }, store => \$opts },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ ### every module has about 10 lines of details
+ ### maybe more later with Module::CPANTS etc
+ $self->_pager_open if scalar @$mods * 10 > $self->_term_rowcount;
+
+
+ my $format = "%-24s %-45s\n";
+ my $cformat = "%-24s %-45s %-10s\n";
+ for my $mod (@$mods) {
+ my $href = $mod->details( %$opts );
+ my @list = sort { $a->module cmp $b->module } $mod->contains;
+
+ unless( $href ) {
+ $self->__print(
+ loc("No details for %1 - it might be outdated.",
+ $mod->module), "\n" );
+ next;
+
+ } else {
+ $self->__print( loc( "Details for '%1'\n", $mod->module ) );
+ for my $item ( sort keys %$href ) {
+ $self->__printf( $format, $item, $href->{$item} );
+ }
+
+ my $showed;
+ for my $item ( @list ) {
+ $self->__printf(
+ $cformat, ($showed ? '' : 'Contains:'),
+ $item->module, $item->version
+ );
+ $showed++;
+ }
+ $self->__print( "\n" );
+ }
+ }
+ $self->_pager_close;
+ $self->__print( "\n" );
+
+ return 1;
+}
+
+sub _print {
+ my $self = shift;
+ my %hash = @_;
+
+ my $args; my $opts; my $file;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ options => { default => { }, store => \$opts },
+ input => { default => '', store => \$file },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ my $old; my $fh;
+ if( $file ) {
+ $fh = FileHandle->new( ">$file" )
+ or( warn loc("Could not open '%1': '%2'", $file, $!),
+ return
+ );
+ $old = select $fh;
+ }
+
+
+ $self->_pager_open if !$file;
+
+ $self->__print( CPANPLUS::Error->stack_as_string );
+
+ $self->_pager_close;
+
+ select $old if $old;
+ $self->__print( "\n" );
+
+ return 1;
+}
+
+sub _set_conf {
+ my $self = shift;
+ my %hash = @_;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+
+ ### possible options
+ ### XXX hard coded, not optimal :(
+ my %types = (
+ reconfigure => '',
+ save => q([user | system | boxed]),
+ edit => '',
+ program => q([key => val]),
+ conf => q([key => val]),
+ mirrors => '',
+ selfupdate => '', # XXX add all opts here?
+ );
+
+
+ my $args; my $opts; my $input;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ options => { default => { }, store => \$opts },
+ input => { default => '', store => \$input },
+ };
+
+ $args = check( $tmpl, \%hash ) or return;
+ }
+
+ my ($type,$key,$value) = $input =~ m/(\w+)\s*(\w*)\s*(.*?)$/;
+ $value =~ s/\s+$//g if $value;
+ $type = lc $type;
+
+ if( $type eq 'reconfigure' ) {
+ my $setup = CPANPLUS::Configure::Setup->new(
+ configure_object => $conf,
+ term => $self->term,
+ backend => $cb,
+ );
+ return $setup->init;
+
+ } elsif ( $type eq 'save' ) {
+ my $where = {
+ user => CONFIG_USER,
+ system => CONFIG_SYSTEM,
+ boxed => CONFIG_BOXED,
+ }->{ $key } || CONFIG_USER;
+
+ ### boxed is special, so let's get its value from %INC
+ ### so we can tell it where to save
+ ### XXX perhaps this logic should be generic for all
+ ### types, and put in the ->save() routine
+ my $dir;
+ if( $where eq CONFIG_BOXED ) {
+ my $file = join( '/', split( '::', CONFIG_BOXED ) ) . '.pm';
+ my $file_re = quotemeta($file);
+
+ my $path = $INC{$file} || '';
+ $path =~ s/$file_re$//;
+ $dir = $path;
+ }
+
+ my $rv = $cb->configure_object->save( $where => $dir );
+
+ $self->__print(
+ $rv
+ ? loc("Configuration successfully saved to %1\n (%2)\n",
+ $where, $rv)
+ : loc("Failed to save configuration\n" )
+ );
+ return $rv;
+
+ } elsif ( $type eq 'edit' ) {
+
+ my $editor = $conf->get_program('editor')
+ or( print(loc("No editor specified")), return );
+
+ my $where = {
+ user => CONFIG_USER,
+ system => CONFIG_SYSTEM,
+ }->{ $key } || CONFIG_USER;
+
+ my $file = $conf->_config_pm_to_file( $where );
+ system($editor,$file);
+
+ ### now reload it
+ ### disable warnings for this
+ { require Module::Loaded;
+ Module::Loaded::mark_as_unloaded( $where );
+
+ ### reinitialize the config
+ local $^W;
+ $conf->init;
+ }
+
+ return 1;
+
+ } elsif ( $type eq 'mirrors' ) {
+
+ $self->__print(
+ loc("Readonly list of mirrors (in order of preference):\n\n" ) );
+
+ my $i;
+ for my $host ( @{$conf->get_conf('hosts')} ) {
+ my $uri = $cb->_host_to_uri( %$host );
+
+ $i++;
+ $self->__print( "\t[$i] $uri\n" );
+ }
+
+ $self->__print(
+ loc("\nTo edit this list, please type: '%1'\n", 's edit') );
+
+ } elsif ( $type eq 'selfupdate' ) {
+ my %valid = map { $_ => $_ }
+ $cb->selfupdate_object->list_categories;
+
+ unless( $valid{$key} ) {
+ $self->__print(
+ loc( "To update your current CPANPLUS installation, ".
+ "choose one of the these options:\n%1",
+ ( join $/, map {
+ sprintf "\ts selfupdate %-17s " .
+ "[--latest=0] [--dryrun]", $_
+ } sort keys %valid )
+ )
+ );
+ } else {
+ my %update_args = (
+ update => $key,
+ latest => 1,
+ %$opts
+ );
+
+
+ my %list = $cb->selfupdate_object
+ ->list_modules_to_update( %update_args );
+
+ $self->__print(loc("The following updates will take place:"),$/.$/);
+
+ for my $feature ( sort keys %list ) {
+ my $aref = $list{$feature};
+
+ ### is it a 'feature' or a built in?
+ $self->__print(
+ $valid{$feature}
+ ? " " . ucfirst($feature) . ":\n"
+ : " Modules for '$feature' support:\n"
+ );
+
+ ### show what modules would be installed
+ $self->__print(
+ scalar @$aref
+ ? map { sprintf " %-42s %-6s -> %-6s \n",
+ $_->name, $_->installed_version, $_->version
+ } @$aref
+ : " No upgrades required\n"
+ );
+ $self->__print( $/ );
+ }
+
+
+ unless( $opts->{'dryrun'} ) {
+ $self->__print( loc("Updating your CPANPLUS installation\n") );
+ $cb->selfupdate_object->selfupdate( %update_args );
+ }
+ }
+
+ } else {
+
+ if ( $type eq 'program' or $type eq 'conf' ) {
+
+ my $format = {
+ conf => '%-25s %s',
+ program => '%-12s %s',
+ }->{ $type };
+
+ unless( $key ) {
+ my @list = grep { $_ ne 'hosts' }
+ $conf->options( type => $type );
+
+ my $method = 'get_' . $type;
+
+ local $Data::Dumper::Indent = 0;
+ for my $name ( @list ) {
+ my $val = $conf->$method($name) || '';
+ ($val) = ref($val)
+ ? (Data::Dumper::Dumper($val) =~ /= (.*);$/)
+ : "'$val'";
+
+ $self->__printf( " $format\n", $name, $val );
+ }
+
+ } elsif ( $key eq 'hosts' or $key eq 'lib' ) {
+ $self->__print(
+ loc( "Setting %1 is not trivial.\n" .
+ "It is suggested you use '%2' and edit the " .
+ "configuration file manually", $key, 's edit')
+ );
+ } else {
+ my $method = 'set_' . $type;
+ $conf->$method( $key => defined $value ? $value : '' )
+ and $self->__print( loc("Key '%1' was set to '%2'", $key,
+ defined $value ? $value : 'EMPTY STRING') );
+ }
+
+ } else {
+ $self->__print( loc("Unknown type '%1'",$type || 'EMPTY' ) );
+ $self->__print( $/ );
+ $self->__print( loc("Try one of the following:") );
+ $self->__print( $/, join $/,
+ map { sprintf "\t%-11s %s", $_, $types{$_} }
+ sort keys %types );
+ }
+ }
+ $self->__print( "\n" );
+ return 1;
+}
+
+sub _uptodate {
+ my $self = shift;
+ my %hash = @_;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+
+ my $opts; my $mods;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ options => { default => { }, store => \$opts },
+ modules => { required => 1, store => \$mods },
+ };
+
+ check( $tmpl, \%hash ) or return;
+ }
+
+ ### long listing? short is default ###
+ my $long = $opts->{'long'} ? 1 : 0;
+
+ my @list = scalar @$mods ? @$mods : @{$cb->_all_installed};
+
+ my @rv; my %seen;
+ for my $mod (@list) {
+ ### skip this mod if it's up to date ###
+ next if $mod->is_uptodate;
+ ### skip this mod if it's core ###
+ next if $mod->package_is_perl_core;
+
+ if( $long or !$seen{$mod->package}++ ) {
+ push @rv, $mod;
+ }
+ }
+
+ @rv = sort { $a->module cmp $b->module } @rv;
+
+ $self->cache([undef,@rv]);
+
+ $self->_pager_open if scalar @rv >= $self->_term_rowcount;
+
+ my $format = "%5s %12s %12s %-36s %-10s\n";
+
+ my $i = 1;
+ for my $mod ( @rv ) {
+ $self->__printf(
+ $format,
+ $i,
+ $self->_format_version($mod->installed_version) || 'Unparsable',
+ $self->_format_version( $mod->version ),
+ $mod->module,
+ $mod->author->cpanid
+ );
+ $i++;
+ }
+ $self->_pager_close;
+
+ return 1;
+}
+
+sub _autobundle {
+ my $self = shift;
+ my %hash = @_;
+ my $cb = $self->backend;
+ my $conf = $cb->configure_object;
+
+ my $opts; my $input;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ options => { default => { }, store => \$opts },
+ input => { default => '', store => \$input },
+ };
+
+ check( $tmpl, \%hash ) or return;
+ }
+
+ $opts->{'path'} = $input if $input;
+
+ my $where = $cb->autobundle( %$opts );
+
+ $self->__print(
+ $where
+ ? loc("Wrote autobundle to '%1'", $where)
+ : loc("Could not create autobundle" )
+ );
+ $self->__print( "\n" );
+
+ return $where ? 1 : 0;
+}
+
+sub _uninstall {
+ my $self = shift;
+ my %hash = @_;
+ my $cb = $self->backend;
+ my $term = $self->term;
+ my $conf = $cb->configure_object;
+
+ my $opts; my $mods;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ options => { default => { }, store => \$opts },
+ modules => { default => [], store => \$mods },
+ };
+
+ check( $tmpl, \%hash ) or return;
+ }
+
+ my $force = $opts->{'force'} || $conf->get_conf('force');
+
+ unless( $force ) {
+ my $list = join "\n", map { ' ' . $_->module } @$mods;
+
+ $self->__print( loc("
+This will uninstall the following modules:
+%1
+
+Note that if you installed them via a package manager, you probably
+should use the same package manager to uninstall them
+
+", $list) );
+
+ return unless $term->ask_yn(
+ prompt => loc("Are you sure you want to continue?"),
+ default => 'n',
+ );
+ }
+
+ ### first loop over all the modules to uninstall them ###
+ for my $mod (@$mods) {
+ $self->__print( loc("Uninstalling '%1'", $mod->module), "\n" );
+
+ $mod->uninstall( %$opts );
+ }
+
+ my $flag;
+ ### then report whether all this went ok or not ###
+ for my $mod (@$mods) {
+ if( $mod->status->uninstall ) {
+ $self->__print(
+ loc("Module '%1' %tense(uninstall,past) successfully\n",
+ $mod->module ) );
+ } else {
+ $flag++;
+ $self->__print(
+ loc("Error %tense(uninstall,present) '%1'\n", $mod->module) );
+ }
+ }
+
+ if( !$flag ) {
+ $self->__print(
+ loc("All modules %tense(uninstall,past) successfully"), "\n" );
+ } else {
+ $self->__print(
+ loc("Problem %tense(uninstall,present) one or more modules" ),
+ "\n" );
+
+ $self->__print(
+ loc("*** You can view the complete error buffer by pressing '%1'".
+ "***\n", 'p') ) unless $conf->get_conf('verbose');
+ }
+ $self->__print( "\n" );
+
+ return !$flag;
+}
+
+sub _reports {
+ my $self = shift;
+ my %hash = @_;
+ my $cb = $self->backend;
+ my $term = $self->term;
+ my $conf = $cb->configure_object;
+
+ my $opts; my $mods;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ options => { default => { }, store => \$opts },
+ modules => { default => '', store => \$mods },
+ };
+
+ check( $tmpl, \%hash ) or return;
+ }
+
+ ### XXX might need to be conditional ###
+ $self->_pager_open;
+
+ for my $mod (@$mods) {
+ my @list = $mod->fetch_report( %$opts )
+ or( print(loc("No reports available for this distribution.")),
+ next
+ );
+
+ @list = reverse
+ map { $_->[0] }
+ sort { $a->[1] cmp $b->[1] }
+ map { [$_, $_->{'dist'}.':'.$_->{'platform'}] } @list;
+
+
+
+ ### XXX this may need to be sorted better somehow ###
+ my $url;
+ my $format = "%8s %s %s\n";
+
+ my %seen;
+ for my $href (@list ) {
+ $self->__print(
+ "[" . $mod->author->cpanid .'/'. $href->{'dist'} . "]\n"
+ ) unless $seen{ $href->{'dist'} }++;
+
+ $self->__printf(
+ $format,
+ $href->{'grade'},
+ $href->{'platform'},
+ ($href->{'details'} ? '(*)' : '')
+ );
+
+ $url ||= $href->{'details'};
+ }
+
+ $self->__print( "\n==> $url\n" ) if $url;
+ $self->__print( "\n" );
+ }
+ $self->_pager_close;
+
+ return 1;
+}
+
+### Load plugins
+{ my @PluginModules;
+ my %Dispatch = (
+ showtip => [ __PACKAGE__, '_show_random_tip'],
+ plugins => [ __PACKAGE__, '_list_plugins' ],
+ '?' => [ __PACKAGE__, '_plugins_usage' ],
+ );
+
+ sub plugin_modules { return @PluginModules }
+ sub plugin_table { return %Dispatch }
+
+ my $init_done;
+ sub _plugins_init {
+
+ ### only initialize once
+ return if $init_done++;
+
+ ### find all plugins first
+ if( check_install( module => 'Module::Pluggable', version => '2.4') ) {
+ require Module::Pluggable;
+
+ my $only_re = __PACKAGE__ . '::Plugins::\w+$';
+
+ Module::Pluggable->import(
+ sub_name => '_plugins',
+ search_path => __PACKAGE__,
+ only => qr/$only_re/,
+ #except => [ INSTALLER_MM, INSTALLER_SAMPLE ]
+ );
+
+ push @PluginModules, __PACKAGE__->_plugins;
+ }
+
+ ### now try to load them
+ for my $p ( __PACKAGE__->plugin_modules ) {
+ my %map = eval { load $p; $p->import; $p->plugins };
+ error(loc("Could not load plugin '$p': $@")), next if $@;
+
+ ### register each plugin
+ while( my($name, $func) = each %map ) {
+
+ if( not length $name or not length $func ) {
+ error(loc("Empty plugin name or dispatch function detected"));
+ next;
+ }
+
+ if( exists( $Dispatch{$name} ) ) {
+ error(loc("'%1' is already registered by '%2'",
+ $name, $Dispatch{$name}->[0]));
+ next;
+ }
+
+ ### register name, package and function
+ $Dispatch{$name} = [ $p, $func ];
+ }
+ }
+ }
+
+ ### dispatch a plugin command to its function
+ sub _meta {
+ my $self = shift;
+ my %hash = @_;
+ my $cb = $self->backend;
+ my $term = $self->term;
+ my $conf = $cb->configure_object;
+
+ my $opts; my $input;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ options => { default => { }, store => \$opts },
+ input => { default => '', store => \$input },
+ };
+
+ check( $tmpl, \%hash ) or return;
+ }
+
+ $input =~ s/\s*(\S+)\s*//;
+ my $cmd = $1;
+
+ ### look up the command, or go to the default
+ my $aref = $Dispatch{ $cmd } || [ __PACKAGE__, '_plugin_default' ];
+
+ my($pkg,$func) = @$aref;
+
+ my $rv = eval { $pkg->$func( $self, $cb, $cmd, $input, $opts ) };
+
+ error( $@ ) if $@;
+
+ ### return $rv instead, so input loop can be terminated?
+ return 1;
+ }
+
+ sub _plugin_default { error(loc("No such plugin command")) }
+}
+
+### plugin commands
+{ my $help_format = " /%-21s # %s\n";
+
+ sub _list_plugins {
+ my $self = shift;
+
+ $self->__print( loc("Available plugins:\n") );
+ $self->__print( loc(" List usage by using: /? PLUGIN_NAME\n" ) );
+ $self->__print( $/ );
+
+ my %table = __PACKAGE__->plugin_table;
+ for my $name( sort keys %table ) {
+ my $pkg = $table{$name}->[0];
+ my $this = __PACKAGE__;
+
+ my $who = $pkg eq $this
+ ? "Standard Plugin"
+ : do { my $v = $self->_format_version($pkg->VERSION) || '';
+ $pkg =~ s/^$this/../;
+ sprintf "Provided by: %-30s %-10s", $pkg, $v;
+ };
+
+ $self->__printf( $help_format, $name, $who );
+ }
+
+ $self->__print( $/.$/ );
+
+ $self->__print(
+ " Write your own plugins? Read the documentation of:\n" .
+ " CPANPLUS::Shell::Default::Plugins::HOWTO\n" );
+
+ $self->__print( $/ );
+ }
+
+ sub _list_plugins_help {
+ return sprintf $help_format, 'plugins', loc("lists available plugins");
+ }
+
+ ### registered as a plugin too
+ sub _show_random_tip_help {
+ return sprintf $help_format, 'showtip', loc("show usage tips" );
+ }
+
+ sub _plugins_usage {
+ my $self = shift;
+ my $shell = shift;
+ my $cb = shift;
+ my $cmd = shift;
+ my $input = shift;
+ my %table = $self->plugin_table;
+
+ my @list = length $input ? split /\s+/, $input : sort keys %table;
+
+ for my $name( @list ) {
+
+ ### no such plugin? skip
+ error(loc("No such plugin '$name'")), next unless $table{$name};
+
+ my $pkg = $table{$name}->[0];
+ my $func = $table{$name}->[1] . '_help';
+
+ if ( my $sub = $pkg->can( $func ) ) {
+ eval { $self->__print( $sub->() ) };
+ error( $@ ) if $@;
+
+ } else {
+ $self->__print(" No usage for '$name' -- try perldoc $pkg");
+ }
+
+ $self->__print( $/ );
+ }
+
+ $self->__print( $/.$/ );
+ }
+
+ sub _plugins_usage_help {
+ return sprintf $help_format, '? [NAME ...]',
+ loc("show usage for plugins");
+ }
+}
+
+### send a command to a remote host, retrieve the answer;
+sub __send_remote_command {
+ my $self = shift;
+ my $cmd = shift;
+ my $remote = $self->remote or return;
+ my $user = $remote->{'username'};
+ my $pass = $remote->{'password'};
+ my $conn = $remote->{'connection'};
+ my $end = "\015\012";
+ my $answer;
+
+ my $send = join "\0", $user, $pass, $cmd;
+
+ print $conn $send . $end;
+
+ ### XXX why doesn't something like this just work?
+ #1 while recv($conn, $answer, 1024, 0);
+ while(1) {
+ my $buff;
+ $conn->recv( $buff, 1024, 0 );
+ $answer .= $buff;
+ last if $buff =~ /$end$/;
+ }
+
+ my($status,$buffer) = split "\0", $answer;
+
+ return ($status, $buffer);
+}
+
+
+sub _read_configuration_from_rc {
+ my $self = shift;
+ my $rc_file = shift;
+
+ my $href;
+ if( can_load( modules => { 'Config::Auto' => '0.0' } ) ) {
+ $Config::Auto::DisablePerl = 1;
+
+ eval { $href = Config::Auto::parse( $rc_file, format => 'space' ) };
+
+ $self->__print(
+ loc( "Unable to read in config file '%1': %2", $rc_file, $@ )
+ ) if $@;
+ }
+
+ return $href || {};
+}
+
+{ my @tips = (
+ loc( "You can update CPANPLUS by running: '%1'", 's selfupdate' ),
+ loc( "You can install modules by URL using '%1'", 'i URL' ),
+ loc( "You can turn off these tips using '%1'",
+ 's conf show_startup_tip 0' ),
+ loc( "You can use wildcards like '%1' and '%2' on search results",
+ '*', '2..5' ) ,
+ loc( "You can use plugins. Type '%1' to list available plugins",
+ '/plugins' ),
+ loc( "You can show all your out of date modules using '%1'", 'o' ),
+ loc( "Many operations take options, like '%1', '%2' or '%3'",
+ '--verbose', '--force', '--skiptest' ),
+ loc( "The documentation in %1 and %2 is very useful",
+ "CPANPLUS::Module", "CPANPLUS::Backend" ),
+ loc( "You can type '%1' for help and '%2' to exit", 'h', 'q' ),
+ loc( "You can run an interactive setup using '%1'", 's reconfigure' ),
+ loc( "You can add custom sources to your index. See '%1' for details",
+ '/cs --help' ),
+ loc( "CPANPLUS now has an experimental SQLite backend. You can enable ".
+ "it via: '%1'. Update dependencies via '%2'",
+ 's conf source_engine CPANPLUS::Internals::Source::SQLite; s save',
+ 's selfupdate enabled_features ' ),
+ );
+
+ sub _show_random_tip {
+ my $self = shift;
+ $self->__print( $/, "Did you know...\n ",
+ $tips[ int rand scalar @tips ], $/ );
+ return 1;
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Shell::Classic>, L<CPANPLUS::Shell>, L<cpanp>
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+__END__
+
+TODO:
+ e => "_expand_inc", # scratch it, imho -- not used enough
+
+### free letters: g j k n y ###
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm
new file mode 100644
index 00000000000..ad4701a488c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm
@@ -0,0 +1,201 @@
+package CPANPLUS::Shell::Default::Plugins::CustomSource;
+
+use strict;
+use CPANPLUS::Error qw[error msg];
+use CPANPLUS::Internals::Constants;
+
+use Data::Dumper;
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+=head1 NAME
+
+CPANPLUS::Shell::Default::Plugins::CustomSource
+
+=head1 SYNOPSIS
+
+ ### elaborate help text
+ CPAN Terminal> /? cs
+
+ ### add a new custom source
+ CPAN Terminal> /cs --add file:///path/to/releases
+
+ ### list all your custom sources by
+ CPAN Terminal> /cs --list
+
+ ### display the contents of a custom source by URI or ID
+ CPAN Terminal> /cs --contents file:///path/to/releases
+ CPAN Terminal> /cs --contents 1
+
+ ### Update a custom source by URI or ID
+ CPAN Terminal> /cs --update file:///path/to/releases
+ CPAN Terminal> /cs --update 1
+
+ ### Remove a custom source by URI or ID
+ CPAN Terminal> /cs --remove file:///path/to/releases
+ CPAN Terminal> /cs --remove 1
+
+ ### Write an index file for a custom source, to share
+ ### with 3rd parties or remote users
+ CPAN Terminal> /cs --write file:///path/to/releases
+
+ ### Make sure to save your sources when adding/removing
+ ### sources, so your changes are reflected in the cache:
+ CPAN Terminal> x
+
+=head1 DESCRIPTION
+
+This is a C<CPANPLUS::Shell::Default> plugin that can add
+custom sources to your CPANPLUS installation. This is a
+wrapper around the C<custom module sources> code as outlined
+in L<CPANPLUS::Backend/CUSTOM MODULE SOURCES>.
+
+This allows you to extend your index of available modules
+beyond what's available on C<CPAN> with your own local
+distributions, or ones offered by third parties.
+
+=cut
+
+
+sub plugins {
+ return ( cs => 'custom_source' )
+}
+
+my $Cb;
+my $Shell;
+my @Index = ();
+
+sub _uri_from_cache {
+ my $self = shift;
+ my $input = shift or return;
+
+ ### you gave us a search number
+ my $uri = $input =~ /^\d+$/
+ ? $Index[ $input - 1 ] # remember, off by 1!
+ : $input;
+
+ my %files = reverse $Cb->list_custom_sources;
+
+ ### it's an URI we know
+ ### VMS can lower case all files, so make sure we check that too
+ my $local = $files{ $uri };
+ $local = $files{ lc $uri } if !$local && ON_VMS;
+
+ if( $local ) {
+ return wantarray
+ ? ($uri, $local)
+ : $uri;
+ }
+
+ ### couldn't resolve the input
+ error(loc("Unknown URI/index: '%1'", $input));
+ return;
+}
+
+sub _list_custom_sources {
+ my $class = shift;
+
+ my %files = $Cb->list_custom_sources;
+
+ $Shell->__print( loc("Your remote sources:"), $/ ) if keys %files;
+
+ my $i = 0;
+ while(my($local,$remote) = each %files) {
+ $Shell->__printf( " [%2d] %s\n", ++$i, $remote );
+
+ ### remember, off by 1!
+ push @Index, $remote;
+ }
+
+ $Shell->__print( $/ );
+}
+
+sub _list_contents {
+ my $class = shift;
+ my $input = shift;
+
+ my ($uri,$local) = $class->_uri_from_cache( $input );
+ unless( $uri ) {
+ error(loc("--contents needs URI parameter"));
+ return;
+ }
+
+ my $fh = OPEN_FILE->( $local ) or return;
+
+ $Shell->__printf( " %s", $_ ) for sort <$fh>;
+ $Shell->__print( $/ );
+}
+
+sub custom_source {
+ my $class = shift;
+ my $shell = shift; $Shell = $shell; # available to all methods now
+ my $cb = shift; $Cb = $cb; # available to all methods now
+ my $cmd = shift;
+ my $input = shift || '';
+ my $opts = shift || {};
+
+ ### show a list
+ if( $opts->{'list'} ) {
+ $class->_list_custom_sources;
+
+ } elsif ( $opts->{'contents'} ) {
+ $class->_list_contents( $input );
+
+ } elsif ( $opts->{'add'} ) {
+ unless( $input ) {
+ error(loc("--add needs URI parameter"));
+ return;
+ }
+
+ $cb->add_custom_source( uri => $input )
+ and $shell->__print(loc("Added remote source '%1'", $input), $/);
+
+ $Shell->__print($/, loc("Remote source contains:"), $/, $/);
+ $class->_list_contents( $input );
+
+ } elsif ( $opts->{'remove'} ) {
+ my($uri,$local) = $class->_uri_from_cache( $input );
+ unless( $uri ) {
+ error(loc("--remove needs URI parameter"));
+ return;
+ }
+
+ 1 while unlink $local;
+
+ $shell->__print( loc("Removed remote source '%1'", $uri), $/ );
+
+ } elsif ( $opts->{'update'} ) {
+ ### did we get input? if so, it's a remote part
+ my $uri = $class->_uri_from_cache( $input );
+
+ $cb->update_custom_source( $uri ? ( remote => $uri ) : () )
+ and do { $shell->__print( loc("Updated remote sources"), $/ ) };
+
+ } elsif ( $opts->{'write'} ) {
+ $cb->write_custom_source_index( path => $input ) and
+ $shell->__print( loc("Wrote remote source index for '%1'", $input), $/);
+
+ } else {
+ error(loc("Unrecognized command, see '%1' for help", '/? cs'));
+ }
+
+ return;
+}
+
+sub custom_source_help {
+ return loc(
+ $/ .
+ ' # Plugin to manage custom sources from the default shell' . $/ .
+ " # See the 'CUSTOM MODULE SOURCES' section in the " . $/ .
+ ' # CPANPLUS::Backend documentation for details.' . $/ .
+ ' /cs --list # list available sources' . $/ .
+ ' /cs --add URI # add source' . $/ .
+ ' /cs --remove URI | INDEX # remove source' . $/ .
+ ' /cs --contents URI | INDEX # show packages from source'. $/ .
+ ' /cs --update [URI | INDEX] # update source index' . $/ .
+ ' /cs --write PATH # write source index' . $/
+ );
+
+}
+
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod
new file mode 100644
index 00000000000..ca765f9e0ac
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/HOWTO.pod
@@ -0,0 +1,136 @@
+=head1 NAME
+
+CPANPLUS::Shell::Default::Plugins::HOWTO -- documentation on how to write your own plugins
+
+=head1 SYNOPSIS
+
+ package CPANPLUS::Shell::Default::Plugins::MyPlugin;
+
+ ### return command => method mapping
+ sub plugins { ( myplugin1 => 'mp1', myplugin2 => 'mp2' ) }
+
+ ### method called when the command '/myplugin1' is issued
+ sub mp1 { .... }
+
+ ### method called when the command '/? myplugin1' is issued
+ sub mp1_help { return "Help Text" }
+
+=head1 DESCRIPTION
+
+This pod text explains how to write your own plugins for
+C<CPANPLUS::Shell::Default>.
+
+=head1 HOWTO
+
+=head2 Registering Plugin Modules
+
+Plugins are detected by using C<Module::Pluggable>. Every module in
+the C<CPANPLUS::Shell::Default::Plugins::*> namespace is considered a
+plugin, and is attempted to be loaded.
+
+Therefor, any plugin must be declared in that namespace, in a corresponding
+C<.pm> file.
+
+=head2 Registering Plugin Commands
+
+To register any plugin commands, a list of key value pairs must be returned
+by a C<plugins> method in your package. The keys are the commands you wish
+to register, the values are the methods in the plugin package you wish to have
+called when the command is issued.
+
+For example, a simple 'Hello, World!' plugin:
+
+ package CPANPLUS::Shell::Default::Plugins::HW;
+
+ sub plugins { return ( helloworld => 'hw' ) };
+
+ sub hw { print "Hello, world!\n" }
+
+When the user in the default shell now issues the C</helloworld> command,
+this command will be dispatched to the plugin, and its C<hw> method will
+be called
+
+=head2 Registering Plugin Help
+
+To provide usage information for your plugin, the user of the default shell
+can type C</? PLUGIN_COMMAND>. In that case, the function C<PLUGIN_COMMAND_help>
+will be called in your plugin package.
+
+For example, extending the above example, when a user calls C</? helloworld>,
+the function C<hw_help> will be called, which might look like this:
+
+ sub hw_help { " /helloworld # prints "Hello, world!\n" }
+
+If you dont provide a corresponding _help function to your commands, the
+default shell will handle it gracefully, but the user will be stuck without
+usage information on your commands, so it's considered undesirable to omit
+the help functions.
+
+=head2 Arguments to Plugin Commands
+
+Any plugin function will receive the following arguments when called, which
+are all positional:
+
+=over 4
+
+=item Classname -- The name of your plugin class
+
+=item Shell -- The CPANPLUS::Shell::Default object
+
+=item Backend -- The CPANPLUS::Backend object
+
+=item Command -- The command issued by the user
+
+=item Input -- The input string from the user
+
+=item Options -- A hashref of options provided by the user
+
+=back
+
+For example, the following command:
+
+ /helloworld bob --nofoo --bar=2 joe
+
+Would yield the following arguments:
+
+ sub hw {
+ my $class = shift; # CPANPLUS::Shell::Default::Plugins::HW
+ my $shell = shift; # CPANPLUS::Shell::Default object
+ my $cb = shift; # CPANPLUS::Backend object
+ my $cmd = shift; # 'helloworld'
+ my $input = shift; # 'bob joe'
+ my $opts = shift; # { foo => 0, bar => 2 }
+
+ ....
+ }
+
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp>
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm
new file mode 100644
index 00000000000..d2b829abded
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Remote.pm
@@ -0,0 +1,186 @@
+package CPANPLUS::Shell::Default::Plugins::Remote;
+
+use strict;
+
+use Module::Load;
+use Params::Check qw[check];
+use CPANPLUS::Error qw[error msg];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+=head1 NAME
+
+CPANPLUS::Shell::Default::Plugins::Remote
+
+=head1 SYNOPSIS
+
+ CPAN Terminal> /connect localhost 1337 --user=foo --pass=bar
+ ...
+ CPAN Terminal@localhost> /disconnect
+
+=head1 DESCRIPTION
+
+This is a C<CPANPLUS::Shell::Default> plugin that allows you to connect
+to a machine running an instance of C<CPANPLUS::Daemon>, allowing remote
+usage of the C<CPANPLUS Shell>.
+
+A sample session, updating all modules on a remote machine, might look
+like this:
+
+ CPAN Terminal> /connect --user=my_user --pass=secret localhost 1337
+
+ Connection accepted
+
+ Successfully connected to 'localhost' on port '11337'
+
+ Note that no output will appear until a command has completed
+ -- this may take a while
+
+
+ CPAN Terminal@localhost> o; i *
+
+ [....]
+
+ CPAN Terminal@localhost> /disconnect
+
+ CPAN Terminal>
+
+=cut
+
+### store the original prompt here, so we can restore it on disconnect
+my $Saved_Prompt;
+
+sub plugins { ( connect => 'connect', disconnect => 'disconnect' ) }
+
+sub connect {
+ my $class = shift;
+ my $shell = shift;
+ my $cb = shift;
+ my $cmd = shift;
+ my $input = shift || '';
+ my $opts = shift || {};
+ my $conf = $cb->configure_object;
+
+ my $user; my $pass;
+ { local $Params::Check::ALLOW_UNKNOWN = 1;
+
+ my $tmpl = {
+ user => { default => 'cpanpd', store => \$user },
+ pass => { required => 1, store => \$pass },
+ };
+
+ check( $tmpl, $opts ) or return;
+ }
+
+ my @parts = split /\s+/, $input;
+ my $host = shift @parts || 'localhost';
+ my $port = shift @parts || '1337';
+
+ load IO::Socket;
+
+ my $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port,
+ ) or (
+ error( loc( "Cannot connect to port '%1' ".
+ "on host '%2'", $port, $host ) ),
+ return
+ );
+
+ my $con = {
+ connection => $remote,
+ username => $user,
+ password => $pass,
+ };
+
+ ### store the connection
+ $shell->remote( $con );
+
+ my($status,$buffer) = $shell->__send_remote_command(
+ "VERSION=$CPANPLUS::Shell::Default::VERSION");
+
+ if( $status ) {
+ print "\n$buffer\n\n";
+
+ print loc( "Successfully connected to '%1' on port '%2'",
+ $host, $port );
+ print "\n\n";
+ print loc( "Note that no output will appear until a command ".
+ "has completed\n-- this may take a while" );
+ print "\n\n";
+
+ ### save the original prompt
+ $Saved_Prompt = $shell->prompt;
+
+ $shell->prompt( $shell->brand .'@'. $host .':'. $port .'> ' );
+
+ } else {
+ print "\n$buffer\n\n";
+
+ print loc( "Failed to connect to '%1' on port '%2'",
+ $host, $port );
+ print "\n\n";
+
+ $shell->remote( undef );
+ }
+}
+
+sub disconnect {
+ my $class = shift;
+ my $shell = shift;
+
+ print "\n", ( $shell->remote
+ ? loc( "Disconnecting from remote host" )
+ : loc( "Not connected to remote host" )
+ ), "\n\n";
+
+ $shell->remote( undef );
+ $shell->prompt( $Saved_Prompt );
+}
+
+sub connect_help {
+ return loc(
+ " /connect [HOST PORT] # Connect to the remote machine,\n" .
+ " # defaults taken from your config\n" .
+ " --user=USER # Optional username\n" .
+ " --pass=PASS # Optional password" );
+}
+
+sub disconnect_help {
+ return loc(
+ " /disconnect # Disconnect from the remote server" );
+}
+
+1;
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp>
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Source.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Source.pm
new file mode 100644
index 00000000000..889b3d3d9bd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Shell/Default/Plugins/Source.pm
@@ -0,0 +1,107 @@
+package CPANPLUS::Shell::Default::Plugins::Source;
+
+use strict;
+use CPANPLUS::Error qw[error msg];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+=head1 NAME
+
+CPANPLUS::Shell::Default::Plugins::Source
+
+=head1 SYNOPSIS
+
+ CPAN Terminal> /source /tmp/list_of_commands /tmp/more_commands
+
+=head1 DESCRIPTION
+
+This is a C<CPANPLUS::Shell::Default> plugin that works just like
+your unix shells source(1) command; it reads in a file that has
+commands in it to execute, and then executes them.
+
+A sample file might look like this:
+
+ # first, update all the source files
+ x --update_source
+
+ # find all of my modules that are on the CPAN
+ # test them, and store the error log
+ a ^KANE$'
+ t *
+ p /home/kane/cpan-autotest/log
+
+ # and inform us we're good to go
+ ! print "Autotest complete, log stored; please enter your commands!"
+
+Note how empty lines, and lines starting with a '#' are being skipped
+in the execution.
+
+=cut
+
+
+sub plugins { return ( source => 'source' ) }
+
+sub source {
+ my $class = shift;
+ my $shell = shift;
+ my $cb = shift;
+ my $cmd = shift;
+ my $input = shift || '';
+ my $opts = shift || {};
+ my $verbose = $cb->configure_object->get_conf('verbose');
+
+ for my $file ( split /\s+/, $input ) {
+ my $fh = FileHandle->new("$file") or(
+ error(loc("Could not open file '%1': %2", $file, $!)),
+ next
+ );
+
+ while( my $line = <$fh> ) {
+ chomp $line;
+
+ next if $line !~ /\S+/; # skip empty/whitespace only lines
+ next if $line =~ /^#/; # skip comments
+
+ msg(loc("Dispatching '%1'", $line), $verbose);
+ return 1 if $shell->dispatch_on_input( input => $line );
+ }
+ }
+}
+
+sub source_help {
+ return loc(' /source FILE [FILE ..] '.
+ '# read in commands from the specified file' ),
+}
+
+1;
+
+=pod
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Shell::Default>, L<CPANPLUS::Shell>, L<cpanp>
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+