diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/CPANPLUS/Configure/Setup.pm | 1653 |
1 files changed, 1653 insertions, 0 deletions
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; |