1652 lines
50 KiB
Perl
1652 lines
50 KiB
Perl
package CPANPLUS::Configure::Setup;
|
|
|
|
use strict;
|
|
use vars qw[@ISA $VERSION];
|
|
$VERSION = "0.9910";
|
|
|
|
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;
|
|
}
|
|
}
|
|
|
|
|
|
|
|
### 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;
|