# $File: //member/autrijus/cpanplus/dist/lib/CPANPLUS/Configure/Setup.pm $ # $Revision: #23 $ $Change: 4048 $ $DateTime: 2002/04/30 12:25:05 $ ################################################## ### CPANPLUS/Configure/Setup.pm ### ### Initial configuration for CPAN++ ### ################################################## package CPANPLUS::Configure::Setup; use strict; use vars '$AutoSetup'; #use Exporter; #use CPANPLUS::Configure; #our @ISA = qw(Exporter); use CPANPLUS::Backend; use Config; use Cwd qw(getcwd); use ExtUtils::MakeMaker (); use File::Path (); use File::Spec; use FileHandle (); use Term::ReadLine; ### EVIL WARNING - FIX THIS ASAP ### ### got it on win2k with AS perl 5.6.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; my $term; ## gather information needed to initialize CPANPLUS ## ## (takes conf => Configure object and term => Term object, returns no values) ## sub init { my ($self, %args) = @_; my $conf = $args{conf}; $term = $args{term} if exists $args{term}; unless ($conf->can_save) { print "*** Error: CPANPLUS $CPANPLUS::Internals::VERSION was not ", "configured properly, and we cannot write to\n", " '$INC{'CPANPLUS/Config.pm'}'.\n". "*** Please check its permission, or contact your administrator.\n"; exit 1; } local $SIG{INT}; #my ($answer, $prompt, $default); print qq[ CPAN is the world-wide archive of perl resources. It consists of about 100 sites that all replicate the same contents all around the globe. Many countries have at least one CPAN site already. The resources found on CPAN are easily accessible with CPANPLUS modules. If you want to use CPANPLUS, you have to configure it properly. ]; my $answer; unless (defined $AutoSetup) { print qq[ Although we recommend an interactive configuration session, you can also enter 'n' here to use default values for all questions. ]; $answer = _get_reply( prompt => "Are you ready for manual configuration? [Y/n]: ", default => 'y', choices => [ qw/y n/ ], ); } local $AutoSetup = 1 if $answer =~ /^n/i; _setup_ftp($conf); _setup_build($conf); _setup_conf($conf); _setup_hosts($conf); ################################################################################ ## ## store it all ## $conf->save; print "\nYour CPAN++ configuration info has been saved!\n\n"; # removes the terminal instance to avoid "Falling back to dumb" no strict 'refs'; undef ${ref($term)."::term"} unless $[ < 5.006; # 5.005 chokes on this } #init ## gather all info needed for the 'conf' hash ## ## (takes Configure object, returns no values) ## sub _setup_conf { my $conf = shift; my ($answer, $prompt, $default); ##################### ## makemaker flags ## ##################### print qq[ 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 $MMflags = _ask_flags( MakeMaker => $conf->get_conf('makemakerflags'), ); ################ ## make flags ## ################ print qq[ 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 $makeflags = _ask_flags( "'make'" => $conf->get_conf('makeflags'), ); ################# ## shift a lib ## ################# print q[ If you like, CPAN++ can add extra directories to your @INC list starts during startup. Enter a space separated list of list to be added to your @INC, quoting anything with embedded whitespace. (To clear the current value enter a single space.) ]; my $lib = $conf->get_conf('lib'); $answer = _get_reply( prompt => "Additional \@INC directories to add? [@{$lib}]: ", default => "@{$lib}", ); if ($answer) { if ($answer =~ m/^\s+$/) { $lib = []; } else { (@{$lib}) = $answer =~ m/\s*("[^"]+"|'[^']+'|[^\s]+)/g; } #if } #if printf "\nYour additional libs are now:\n"; if (@{$lib}) { print map { " $_\n" } @{$lib}; } else { print " *nothing entered*\n"; } #if print "\n"; ############ ## noisy? ## ############ print q[ 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. ]; $answer = _get_reply( prompt => "Should I be verbose? [N/y]: ", default => 'n', choices => [ qw/y n/ ], ); my $verbose; print "\n"; if ($answer =~ /^y/i) { $verbose = 1; print "You asked for it!"; } else { $verbose = 0; print "I'll try to be quiet."; } #if print "\n\n"; ####################### ## flush you animal! ## ####################### print q[ 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. ]; $answer = _get_reply( prompt => "Flush automatically? [Y/n]: ", default => 'Y', choices => [ qw/y n/ ], ); my $flush; print "\n"; if ($answer =~ /^y/i) { $flush = 1; print "I'll flush after every full module install."; } else { $flush = 0; print "I won't flush until you tell me to. (It could get smelly in here! ;o)"; } #if print "\n\n"; ################### ## get in there! ## ################### print q[ Usually, when a test fails, I won't install the module, but if you prefer, I can force the install anyway. ]; $answer = _get_reply( prompt => "Force installs? [N/y]: ", default => 'n', choices => [ qw/y n/ ], ); my $force; print "\nOk, "; if ($answer =~ /^y/i) { $force = 1; print "I will"; } else { $force = 0; print "I won't"; } #if print " force installs.\n\n"; ################################ ## follow, follow, follow me! ## ################################ print q[ Sometimes a module will require other modules to be installed before it will work. CPAN++ 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.) Otherwise, select ASK to have us ask your permission to install them. ]; $answer = _get_reply( prompt => "Follow prereqs? [A/y/n]: ", default => 'a', choices => [ qw/y n a/ ], ); my $prereqs; print "\nOk, "; if ($answer =~ /^y/i) { $prereqs = 1; print "I will"; } elsif ( $answer =~ /^a/i) { $prereqs = 2; print "I will ask permission to"; } else { $prereqs = 0; print "I won't"; } #if print " follow prereqs.\n\n"; #################### ## safety is good ## #################### print q[ The modules in the CPAN archives are protected with md5 checksums. ]; my $have_md5 = eval "use Digest::MD5; 1"; $answer = _get_reply( prompt => "Use the md5 checksums? "._yn($have_md5), default => $have_md5 ? 'y' : 'n', choices => [ qw/y n/ ], ); my $md5; print "\nOk, "; if ($answer =~ /^y/i) { $md5 = 1; print "I will"; } else { $md5 = 0; print "I won't"; } #if print " use md5 if you have it.\n\n"; ########################################### ## sally sells seashells by the seashore ## ########################################### print q[ By default CPAN++ uses it's 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 $shell = $conf->get_conf('shell') || ''; $shell = _get_reply( prompt => "CPAN++ 'shell' you want to use? [$shell]: ", default => $shell, ); print "\nYour 'shell' is now:\n $shell\n", if ($shell); print "\n"; ################### ## use storable? ## ################### print q[ To speed up the start time of CPAN++ we can use Storable to freeze some information. Would you like to do this? ]; my $have_storable = eval "use Storable; 1"; $answer = _get_reply( prompt => "Use Storable? "._yn($have_storable), default => $have_storable ? 'y' : 'n', choices => [ qw/y n/ ], ); my $storable; print "\n"; if ($answer =~ /^y/i) { $storable = 1; print "I will use Storable if you have it."; } else { $storable = 0; print "I am NOT going to use Storable."; } #if print "\n\n"; ################### ## use cpantest? ## ################### print q[ CPANPLUS comes with the "cpantest" utility, 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. ]; $answer = _get_reply( prompt => "Report tests results? [y/N]: ", default => 'n', choices => [ qw/y n/ ], ); my $cpantest; print "\nOk, "; if ($answer =~ /^y/i) { $cpantest = 1; print "I will prompt you to"; } else { $cpantest = 0; print "I won't"; } #if print " report test results.\n\n"; print "\n\n"; ############## ## save it! ## ############## $conf->set_conf( cpantest => $cpantest, force => $force, lib => $lib, makeflags => $makeflags, makemakerflags => $MMflags, md5 => $md5, prereqs => $prereqs, shell => $shell, storable => $storable, verbose => $verbose, ); } #_setup_conf ## gather all info needed for the '_ftp' hash, ## except 'urilist' is handled in _setup_hosts ## ## (takes Configure object, returns no values) ## sub _setup_ftp { my $conf = shift; my ($answer, $prompt, $default); ######################### ## are you a pacifist? ## ######################### print q[ If you are connecting through a firewall or proxy that doesn't handle FTP all that well you can use passive FTP. ]; $answer = _get_reply( prompt => "Use passive FTP? [Y/n]: ", default => 'y', choices => [ qw/y n/ ], ); my $passive; print "\n"; if ($answer =~ /^y/i) { $passive = 1; ### 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} = 1; print "I will"; } else { $passive = 0; print "I won't"; } #if print " use passive FTP.\n\n"; ############################ ## where can I reach you? ## ############################ print q[ 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. ]; my $email = $conf->_get_ftp('email') || 'cpanplus@example.com'; my $cf_mail = $Config{cf_email}; $cf_mail = 'cpanplus@example.com' if $cf_mail eq $email; # for variety's sake print qq| You have several choices: 1) $email 2) $cf_mail 3) something else |; $prompt = 'Please pick one [1]: '; $default = '1'; while (defined($answer = _readline($prompt))) { $answer ||= $default; $term->addhistory($answer); last, if $answer == 1; $email = $cf_mail, last, if $answer == 2; $email = '', last, if $answer == 3; $prompt = 'Please choose 1, 2, or 3 [1]: '; next; } #while until ( _valid_email($email) ) { print "You did not enter a valid email address, please try again!\n" if length $email; $email = _get_reply( prompt => "Email address: ", ); } #while print "\nYour 'email' is now:\n $email\n"; print "\n"; ############## ## save it! ## ############## $conf->_set_ftp( email => $email, passive => $passive, ); } #_setup_ftp ## gather all info needed for the '_build' hash ## ## (takes Configure object, returns no values) ## sub _setup_build { my $conf = shift; my ($answer, $prompt, $default); ################# ## CPAN++ home ## ################# print qq[ The CPAN++ module 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. ]; my $new_path; my $dot_cpan = '.cpanplus'; ### add more checks later - good for Win9x/NT4/Win2k and *nix now ### this breaks cygwin, thanks -kane #if ($^O =~ m/win/i) { if ( $^O eq 'MSWin32' ) { V: { #$new_path = $ENV{WIN2KTEST}, last V, if exists $ENV{USERPROFILE}; $new_path = $ENV{USERPROFILE}, last V, if exists $ENV{USERPROFILE}; $new_path = $ENV{WINDIR}, last V, if exists $ENV{WINDIR}; } #V $new_path = File::Spec->catdir($new_path, 'Application Data', $dot_cpan); ### this seems a rather dangerous thing -kane ### #$new_path =~ s|\\|/|g; # makes everything look better } else { $new_path = File::Spec->catdir($ENV{HOME}, $dot_cpan); } #if my $cpan_home = $conf->_get_build('base') || $new_path; #$cpan_home =~ s|\\|/|g, if $^O eq 'MSWin32'; # beautify windoze if ($cpan_home ne $new_path) { print qq| You have several choices: 1) $new_path 2) $cpan_home 3) somewhere else |; $prompt = 'Please pick one [1]: '; $default = '1'; while (defined($answer = _readline($prompt))) { $answer ||= $default; $term->addhistory($answer); $cpan_home = $new_path, last, if $answer == 1; last, if $answer == 2; $cpan_home = '', last, if $answer == 3; $prompt = 'Please choose 1, 2, or 3 [1]: '; next; } #while } #if if (-d $cpan_home) { print qq{ I see you already have a directory: $cpan_home }; $prompt = 'Should I use it? [Y/n]: '; $default = 'y'; } else { print qq{ First of all, I'd like to create this directory. Where? }; $prompt = "[$cpan_home]: "; $default = $cpan_home; } #if while (defined($answer = _readline($prompt))) { $answer ||= $default; $term->addhistory($answer); if ($default eq 'y') { if ($answer =~ /^y/i) { $answer = $cpan_home; } else { $prompt = 'Where shall I put it then?: '; $default = ''; next; } #if } #if $prompt = 'Please choose a different location: '; $default = ''; if (-d $answer and not (-w _)) { print "I can't seem to write in this directory.\n"; $AutoSetup = 0; next; } #if ### windoze won't make more than one dir at a time :o( #unless (mkdir $answer) { { local $@; unless (-d $answer or eval { File::Path::mkpath($answer) } ) { chomp($@); warn "I wasn't able to create this directory.\n(The error I got was $@)\n\n"; $AutoSetup = 0; next; } #unless } #scope my $autdir = File::Spec->catdir($answer, $conf->_get_build('autdir')); unless (-e $autdir or mkdir($autdir, 0777)) { warn "I wasn't able to create $autdir.\n(The error I got was $!)\n\n"; $AutoSetup = 0; next; # XXX: doesn't unlink the current $answer } my $moddir = File::Spec->catdir($answer, $conf->_get_build('moddir')); unless (-e $moddir or mkdir($moddir, 0777)) { warn "I wasn't able to create $moddir.\n(The error I got was $!)\n\n"; $AutoSetup = 0; next; # XXX: doesn't unlink the current $answer } $cpan_home = Cwd::abs_path($answer); ### clear away old storable images before 0.031 unlink File::Spec->catfile($cpan_home, 'dslip'); unlink File::Spec->catfile($cpan_home, 'mailrc'); unlink File::Spec->catfile($cpan_home, 'packages'); print "\nYour CPAN++ build and cache directory has been set to:\n"; print " $cpan_home\n"; last; } #while print "\n\n"; ############################### ## whereis make/tar/gzip/etc ## ############################### my (@path) = split /$Config{path_sep}/, $ENV{PATH}; my ($new_name, $pgm_name); my %pgms = ( ftp => '', gzip => '', lynx => '', make => '', ncftp => '', ncftpget => '', pager => '', #perl => '', # favor finding this at runtime #shell => '', tar => '', unzip => '', wget => '', ); for my $pgm (sort keys %pgms) { #unless ($pgm eq 'perl') { # favor finding this at runtime my $name = $Config{$pgm} || $pgm; $name ||= $ENV{PAGER} || 'more' if ($pgm eq 'pager'); $new_name = (_find_exe($name, [@path]) || MM->maybe_command($name)) ? $name : ''; $new_name ||= 'ncftp3' if $pgm eq 'ncftp' and (_find_exe('ncftp3', [@path]) || MM->maybe_command('ncftp3')); #} else { # $new_name = $^X; # favor finding this at runtime #} #unless #$new_name =~ s|\\|/|g, if $^O eq 'MSWin32'; # pretty up windoze $name = $conf->_get_build($pgm); if ($name) { $pgm_name = (_find_exe($name, [@path]) || MM->maybe_command($name)) ? $name : $new_name; #$pgm_name =~ s|\\|/|g, if $^O eq 'MSWin32'; # pretty up windoze } else { $pgm_name = $new_name; } if ($pgm_name ne $new_name) { print qq| Which '$pgm' executable should I use? 1) $new_name 2) $pgm_name 3) other |; $prompt = 'Please pick one [1]: '; $default = 1; } else { $prompt = "Where can I find your '$pgm' executable? [$pgm_name]: "; $default = $pgm_name; } #if while (defined($answer = _readline($prompt))) { $answer ||= $default; $answer =~ s/^\s+$//; $term->addhistory($answer), if $answer; if ($default =~ /^[123]$/) { unless ($answer == 1 || $answer == 2 || $answer == 3) { $prompt = 'Please choose 1, 2, or 3 [1]: '; next; } #unless $answer = $new_name, if $answer == 1; $answer = $pgm_name, if $answer == 2; if ($answer == 3) { $prompt = "Where can I find your '$pgm' executable?: "; $default = ''; $AutoSetup = 0; next; } #if } #if $pgm_name = $answer; # some can be blank, but NOT perl or make #last, unless $pgm_name or $pgm =~ m/^make|perl$/; unless ($pgm_name) { #last, unless $pgm =~ m/^make|perl$/; # favor finding this at runtime last, unless $pgm eq 'make'; warn "Without your '$pgm' executable I can't function!\n"; $AutoSetup = 0; next; } #unless # it better actually be a program! last, if File::Spec->file_name_is_absolute($answer) && MM->maybe_command($answer); $answer = _find_exe($answer, [@path]); unless ($answer) { warn "I couldn't find '$pgm_name' in your PATH.\n"; $prompt = "Please tell me where I can find it: "; $default = ''; $AutoSetup = 0; next; } #unless print "\nGood, I found '$pgm_name' in your PATH:\n $answer\n"; last; } #while printf "\nYour '$pgm' program has been set to:\n %s\n", ($pgm_name) ? $pgm_name : '*nothing entered*'; print "\n\n"; $pgms{$pgm} = $pgm_name; } #for ############## ## save it! ## ############## $conf->_set_build( 'base' => $cpan_home, %pgms, ); } #_setup_build ### helper module for makeflags and makemakerflags sub _ask_flags { my ($name, $old) = @_; ### do a one-level deep copy of the original value my $flags = (UNIVERSAL::isa($old, 'HASH')) ? { %{$old} } : {}; if (%{$flags}) { print "Your current $name flags are:\n"; print map { defined($flags->{$_}) ? " $_=$flags->{$_}\n" : " $_\n" } sort keys %{$flags}; print "\n\n"; } #if my $answer = _get_reply( prompt => "Parameters for $name?: " ); $flags = CPANPLUS::Backend->_flags_hashref($answer); print "\nYour $name flags are now:\n"; if (%{$flags}) { print map { defined($flags->{$_}) ? " $_=$flags->{$_}\n" : " $_\n" } sort keys %{$flags}; } else { print " *nothing entered*\n"; } #if print "\n"; return $flags; } ## locate a given executable in the given path ## ## (takes scalar and arrayref, returns scalar) ## sub _find_exe { my ($exe, $path) = @_; my $param = (($exe =~ s/(\s+.*)//) ? $1 : ''); for my $dir (@{$path}) { my $abs = File::Spec->catfile($dir, $exe); return $abs.$param if $abs = MM->maybe_command($abs); } #for } #_find_exe ## gather all info needed for 'urilist' hash inside '_ftp' ## ## (takes Configure object, returns no values) ## sub _setup_hosts { my $conf = shift; my ($answer, $prompt, $default); print q[ Now, we are going to fetch the mirror list for first-time configurations. This may take a while... ]; #my $file = '/tmp/MIRRORED.BY'; my $file = File::Spec->catfile($conf->_get_build('base'), $conf->_get_source('hosts')); unless (-e $file) { my $cpan = new CPANPLUS::Backend($conf) or die "can't use Backend!\n"; $cpan->_fetch( file => $conf->_get_source('hosts'), fetchdir => $conf->_get_build('base'), ) or die "Fetch of $file failed!\n"; } #unless my $hosts = _parse_mirrored_by($file); my ($default_continent, $default_country, $default_host) = _guess_from_timezone($hosts); print qq{ Now we need to know where your favorite CPAN sites are located. Push a few sites onto the array (just in case the first on the array won't work). If you are mirroring CPAN to your local workstation, specify a file: URL. 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 some of those URLs. Finally, you will be prompted for any extra URLs -- file:, ftp:, or http: -- that host a CPAN mirror. }; my $choices; my $count; $default = ''; my ($continent, $country, $last, $next, $host_list, @hosts); my @answers; $next = 'continent'; my $options = { continent => [ qw/q/ ], country => [ qw/q u/ ], host => [ qw/q u v/ ], view => [ qw/y n/ ], }; LOOP: { if ($next eq 'continent') { my $items = [sort keys %{$hosts->{all}}]; my $default = _find_seq($items, $default_continent); my $pick = _pick_item ( #items => [sort keys %{$hosts->{all}}], items => $items, options => { q => 'quit', }, #prompt => 'Please choose a continent: ', prompt => "Please choose a continent [$default]: ", choices => [ @{$options->{continent}} ], default => $default, ); if ($pick->[0] =~ /\d/) { $continent = $pick->[1]; $next = 'country'; } elsif ($pick->[0] eq 'q') { last LOOP; } #if redo LOOP; } elsif ($next eq 'country') { my $items = [ sort keys %{$hosts->{all}->{$continent}} ]; my $default = _find_seq($items, $default_country); my $pick = _pick_item ( #items => [sort keys %{$hosts->{all}->{$continent}}], items => $items, options => { q => 'quit', u => 'back to continents', }, #prompt => 'Please choose a country: ', prompt => "Please choose a country [$default]: ", choices => [ @{$options->{country}} ], default => $default, ); if ($pick->[0] =~ /\d/) { $country = $pick->[1]; $next = 'host'; } elsif ($pick->[0] eq 'q') { last LOOP; } elsif ($pick->[0] eq 'u') { $next = 'continent'; } #if redo LOOP; } elsif ($next eq 'host') { my $opts = { q => 'finish', u => 'back to countries', v => (scalar(keys %$host_list)) > 0 ? 'view list' : '', #v => (defined($host_list) && scalar @{$host_list}) > 0 ? 'view list' : '', }; my $sub = sub { return "[$_[0]] $_[1]" . " ($hosts->{$_[1]}->{frequency}" . ", $hosts->{$_[1]}->{dst_bandwidth})\n"; }; my $items = [ sort @{$hosts->{all}->{$continent}->{$country}} ]; my $default = _find_seq($items, $default_host); my $pick = _pick_item ( #items => [ sort @{$hosts->{all}->{$continent}->{$country}} ], items => $items, options => $opts, map_sub => $sub, #prompt => 'Please choose a host: ', prompt => "Please choose a host [$default]: ", choices => [ @{$options->{host}} ], default => $default, multi => 1, ); if ($pick->[0] =~ /\d/) { for my $host (@{$pick}[1..$#{$pick}]) { if (exists $host_list->{$host}) { print "\nHost $host already selected!\n"; last LOOP if $AutoSetup; next; } push @hosts, $host; $host_list->{$host} = $hosts->{$host}; my $total = scalar(keys %{$host_list}); printf "\nSelected %s, %d host%s selected thus far.\n", $host, $total, ($total == 1) ? '' : 's'; } $next = 'host'; } elsif ($pick->[0] eq 'q') { last LOOP; } elsif ($pick->[0] eq 'u') { $next = 'country'; } elsif ($pick->[0] eq 'v') { $next = 'view'; } #if redo LOOP; } elsif ($next eq 'view') { print "\n\nCurrently selected hosts:"; my $pick = _pick_item ( #items => [ @{$host_list} ], #items => [ sort keys %{$host_list} ], items => [ @hosts ], map_sub => sub { return " $_[1]\n" }, prompt => 'Choose another? [Y/n]: ', default => 'y', choices => [ @{$options->{view}} ], ); if ($pick->[0] eq 'n') { last LOOP; } else { $next = 'host'; } #if redo LOOP; } #if } #LOOP #my @list = map { @hosts = map { #my ($scheme, $path) = split /$_/, $host_list->{$_}->{dst_ftp}; #my ($path) = $host_list->{$_}->{dst_ftp} =~ m/$_(.*)$/; { host => $_, #path => $path, path => $host_list->{$_}->{path}, #scheme => $scheme, scheme => $host_list->{$_}->{scheme}, } #} sort keys %{$host_list}; } @hosts; ## the default fall-back host for unfortunate users my $fallback_host = 'ftp://ftp.cpan.org/pub/CPAN/'; print qq{ 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 lynx is installed. (Enter an empty string 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 }; while ('kane is happy') { $answer = _get_reply( prompt => "Additional host(s) to add". ($fallback_host ? " [$fallback_host]: " : ": "), default => $fallback_host, ); ## first-time only. $fallback_host = ''; ## oh, you want to quit (_get_reply returns empty string given no input) last unless $answer =~ /\S/; my @given = split(' ', $answer); #little-documented awk-like behavior for my $uri (@given) { ## break up into scheme/host/path ## cheat here and reject all but full uri's without auth data ## (real cheesy basic check - NOT a full URI validation!) my ($scheme, $host, $path) = $uri =~ m{^([a-zA-Z]+)://([a-zA-Z0-9\.-]*)(/.*)$}; ## only file URI's allowed to leave host blank (localhost assumed) $host = 'localhost' if $scheme eq 'file' and $host eq ''; ## no schemey, no hosty, no pathy, no worky next unless $scheme and $host and $path; #my $item = { # host => $host, # path => $path, # scheme => $scheme, # }; ## don't store duplicate items #push (@hosts, $item) unless exists $host_list->{$host}; ## don't store duplicate items ## maybe we don't care or want to override them though? -jmb ## need to allow for multiple localhost hosts somehow #unless ($host ne 'localhost' and exists $host_list->{$host}) { unless ($scheme ne 'file' and exists $host_list->{$host} and $path ne $host_list->{$host}->{path}) { push @hosts, { host => $host, path => $path, scheme => $scheme, }; $host_list->{$host} = 1; ## keep track of these } #unless } #for } #while print "\nYour current hosts are:\n", ( map { ( "$_->{host}", #($_->{host} eq 'localhost') ? " ($_->{path})" : '', ($_->{scheme} eq 'file') ? " ($_->{path})" : '', "\n" ); } @hosts ), "\n"; ### MUST CHANGE THIS - I HATE IT!!! -jmb $conf->_set_ftp( #urilist => [ @list ], urilist => [ @hosts ], ); #$conf->_set_hosts( # #order => [ sort keys %{$host_list} ], # #list => $host_list, # #list => [ @list ], #); } #_setup_hosts ## consolidated picker routine ## ## Displays a picklist and asks for a reply. ## ## You supply: ## map_sub => subref used to display picklist ## items => arrayref with items in picklist ## options => hashref with options not in picklist ## multi => flag to indicate a multiple choice question ## and any additional args for _get_reply ## ## For your trouble you get an arrayref with the user supplied answer and the ## associated item. ## ## (takes hash, returns arrayref) ## sub _pick_item { my %args = @_; my ($count, $choices); my $sub = $args{map_sub} || sub { return "[$_[0]] $_[1]\n"; }; ## build main list my @list = map { $choices->{++$count} = $_; $sub->($count, $_); } @{$args{items}}; ## build option list push @list, map { ("[$_] $args{options}->{$_}\n"), if $args{options}->{$_}; } sort keys %{$args{options}}; $args{prompt} =~ s/ \[\]:$/:/; # remove empty defaults print "\n\n", @list, "\n"; ## add generated choices to list push @{$args{choices}}, keys %{$choices}; ## get the reply my $answer = _get_reply(%args); return [ $answer, @{$choices}{split(/\s+/, $answer)} ]; } #_pick_item ## generic reply processor ## ## Asks for, and stubbornly refuses to accept anything but, a valid reply. ## ## You supply: ## prompt => prompt for user display ## default => default answer, if any ## choices => list of valid replies ## multi => flag to indicate a multiple choice question ## ## For your trouble you get the user supplied answer. ## ## (takes hash, returns scalar) ## sub _get_reply { my %args = @_; # On win32, we limit ourselves to the dumb terminal. # -autrijus: eventually we'd want CPANPLUS::Term that wraps this up. LOOP: { my $answer = _readline($args{prompt}); $answer = $args{default} unless length $answer; $answer = '' unless length $answer; $term->addhistory($answer) if length $answer and !$AutoSetup; if (exists $args{choices}) { my @answers = $args{multi} ? split(/\s+/, $answer) : $answer; unless (@answers == grep { my $ans = $_; grep { lc($_) eq lc($ans) } @{$args{choices}} } @answers) { #$args{prompt} = 'Invalid selection, please try again: '; warn "Invalid selection, please try again.\n"; redo LOOP; } #unless } #if return $answer; } #LOOP } #_get_reply sub _readline { if ($AutoSetup) { print @_; print "\n"; return ''; } my $TR = ($^O eq 'MSWin32') ? 'Term::ReadLine::Stub' : 'Term::ReadLine'; $term ||= $TR->new('CPANPLUS Configuration', *STDIN, *STDOUT); return $term->readline(@_); } ## MIRRORED.BY parser ## ## Converts a given MIRRORED.BY file into usable data without an eval. ## ## (takes scalar, returns hashref) ## sub _parse_mirrored_by { my $file = shift; my $fh = new FileHandle; ### file should have a size, else there is a problem ### -s $file or die "$file has no size!"; $fh->open("<$file") or die "Couldn't open $file: $!"; { local $/ = undef; $file = <$fh>; } $fh->close; $file =~ s/#.*$//gm; # squash comments #open (DEBUG, '>debug.txt') or die $!; my $hosts; %{$hosts} = $file =~ m/([a-zA-Z0-9\-\.]+):\s+((?:\w+\s+=\s+".*?"\s+)+)/gs; #print DEBUG Data::Dumper->Dump([$hosts], ['hosts']); for my $h (sort keys %{$hosts}) { #print DEBUG "h is $h, ", Data::Dumper->Dump([$hosts->{$h}], ['host1']); my $el; #%{$el} = $hosts->{$h} =~ m/(\w+)\s+=\s+"(.+?)"\s+/gs; %{$el} = $hosts->{$h} =~ m/(\w+)\s+=\s+"(.*?)"\s+/gs; #print DEBUG Data::Dumper->Dump([$el], ['host1']); ## cripple it to ftp for now #next, unless exists $el->{dst_ftp}; #next, unless $el->{dst_ftp}; ## can't just go to next, must delete this host ## (else _guess_from_timezone chokes) unless ($el->{dst_ftp}) { delete $hosts->{$h}; next; } #unless ($el->{path}) = $el->{dst_ftp} =~ m/$h(.*)$/; #print DEBUG "dst_ftp: ", $el->{dst_ftp}, ", path: ", $el->{path}, "\n"; $el->{scheme} = 'ftp'; my $lat_long; ($el->{city_area}, $el->{country}, $el->{continent}, $lat_long) = $el->{dst_location} =~ #"Aizu-Wakamatsu, Tohoku-chiho, Fukushima, Japan, Asia (37.4333 139.9821)" 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) ((?:\(.*)?)$ # (latitude longitude) /sx; @{$el->{lat_long}} = $lat_long =~ m/\((\S+)\s+(\S+?)\)/; $el->{dst_bandwidth} ||= 'unknown'; $hosts->{$h} = $el; push @{$hosts->{all}->{$el->{continent}}->{$el->{country}}}, $h; #print DEBUG Data::Dumper->Dump([$el], ['host2']); } #for #print DEBUG Data::Dumper->Dump([$hosts], ['hosts']); #close DEBUG; return $hosts; } #_parse_mirrored_by ## 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 { ### autrijus - build time zone table my $hosts = shift; my (%zones, %countries, %sites); 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/^\+//; $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 ## finds a target's position in a given arrayref ## ## (takes arrayref and scalar, returns scalar) ## sub _find_seq { my ($ref, $target) = @_; ### $target will be undef sometimes -jmb if ($target) { #local $_; #($ref->[$_] eq $target) and return ($_ + 1) for (0 .. $#{$ref}); ### this seems clearer to me -jmb for my $count (0 .. $#{$ref}) { return ($count + 1) if $ref->[$count] eq $target; } } return ''; } # _find_seq ## Test email validness against RFC 822, using Jeffrey Friedl's optimized ## example in _Mastering Regular Expressions_ (http://www.ora.com/catalog/regex/). ## ## (takes string, returns bolean) ## { my $RFC822PAT; # RFC pattern to match for valid email address sub _valid_email { 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); } } sub _yn { return $_[0] ? '[Y/n]: ' : '[y/N]'; } 1; =pod =head1 NAME CPANPLUS::Configure::Setup - Configuration setup for CPAN++ =head1 SYNOPSIS You will be automatically thrown to Setup when you install CPANPLUS, or whenever your saved Config is corrupt. You can run Setup explicitly (which will replace your existing Config) with: perl -MCPANPLUS::Configure::Setup -e 'CPANPLUS::Configure::Setup->init()' =head1 DESCRIPTION CPANPLUS::Configure::Setup prompts the user to enter information that will be used by CPANPLUS. The text accompanying the questions should be sufficient to guide the user through the configuration. The result of this inquiry is stored in Config.pm. By default, this information will be used by all CPANPLUS modules. However, it is possible to change some configuration options at runtime with CPANPLUS::Configure (which will probably be accessed through CPANPLUS::Backend). =head1 AUTHORS This module by Joshua Boschert E<lt>jambe@cpan.orgE<gt>. This pod text by Ann Barcomb E<lt>kudra@cpan.orgE<gt>. =head1 COPYRIGHT The CPAN++ interface (of which this module is a part of) is copyright (c) 2001, 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<CPANPLUS::Configure>, L<CPANPLUS::Backend> =cut # Local variables: # c-indentation-style: bsd # c-basic-offset: 4 # indent-tabs-mode: nil # End: # vim: expandtab shiftwidth=4: