summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm1654
1 files changed, 0 insertions, 1654 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm
deleted file mode 100644
index 8ac565a70ec..00000000000
--- a/Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm
+++ /dev/null
@@ -1,1654 +0,0 @@
-package CPANPLUS::Configure::Setup;
-use deprecate;
-
-use strict;
-use vars qw[@ISA $VERSION];
-$VERSION = "0.9135";
-
-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 separating 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 new configuration ###
- $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;
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-21 05:12:30 +0000