1 package CPANPLUS::Configure::Setup;
6 use base qw[CPANPLUS::Internals::Utils];
7 use base qw[Object::Accessor];
15 use CPANPLUS::Internals::Utils;
16 use CPANPLUS::Internals::Constants;
19 use IPC::Cmd qw[can_run];
20 use Params::Check qw[check];
21 use Module::Load::Conditional qw[check_install];
22 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
25 $Term::UI::VERBOSE = 0;
27 #Can't ioctl TIOCGETP: Unknown error
28 #Consider installing Term::ReadKey from CPAN site nearby
29 # at http://www.perl.com/CPAN
31 # perl -MCPAN -e shell
32 #to reach CPAN. Falling back to 'stty'.
33 # If you do not want to see this warning, set PERL_READLINE_NOWARN
35 #'stty' is not recognized as an internal or external command,
36 #operable program or batch file.
37 #Cannot call `stty': No such file or directory at C:/Perl/site/lib/Term/ReadLine/
39 ### setting this var in the meantime to avoid this warning ###
40 $ENV{PERL_READLINE_NOWARN} = 1;
48 configure_object => { },
51 autoreply => { default => 0, },
52 skip_mirrors => { default => 0, },
53 use_previous => { default => 1, },
54 config_type => { default => CONFIG_USER },
57 my $args = check( $tmpl, \%hash ) or return;
60 my $obj = $class->SUPER::new( keys %$tmpl );
61 for my $acc ( $obj->ls_accessors ) {
62 $obj->$acc( $args->{$acc} );
65 ### otherwise there's a circular use ###
66 load CPANPLUS::Configure;
67 load CPANPLUS::Backend;
69 $obj->configure_object( CPANPLUS::Configure->new() )
70 unless $obj->configure_object;
72 $obj->backend( CPANPLUS::Backend->new( $obj->configure_object ) )
75 ### use empty string in case user only has T::R::Stub -- it complains
76 $obj->term( Term::ReadLine->new('') )
79 ### enable autoreply if that was passed ###
80 $Term::UI::AUTOREPLY = $obj->autoreply;
87 my $term = $self->term;
89 ### default setting, unless changed
90 $self->config_type( CONFIG_USER ) unless $self->config_type;
92 my $save = loc('Save & exit');
93 my $exit = loc('Quit without saving');
95 # key on the display # method to dispatch to
96 [ loc('Select Configuration file') => '_save_where' ],
97 [ loc('Setup CLI Programs') => '_setup_program' ],
98 [ loc('Setup CPANPLUS Home directory') => '_setup_base' ],
99 [ loc('Setup FTP/Email settings') => '_setup_ftp' ],
100 [ loc('Setup basic preferences') => '_setup_conf' ],
101 [ loc('Setup installer settings') => '_setup_installer' ],
102 [ loc('Select mirrors'), => '_setup_hosts' ],
103 [ loc('Edit configuration file') => '_edit' ],
104 [ $save => '_save' ],
108 my @keys = map { $_->[0] } @map; # sorted keys
109 my %map = map { @$_ } @map; # lookup hash
113 =================> MAIN MENU <=================
115 Welcome to the CPANPLUS configuration. Please select which
116 parts you wish to configure
118 Defaults are taken from your current configuration.
119 If you would save now, your settings would be written to:
123 ", $self->config_type );
125 my $choice = $term->get_reply(
126 prompt => "Section to configure:",
131 ### exit configuration?
132 if( $choice eq $exit ) {
134 Quitting setup, changes will not be saved.
139 my $method = $map{$choice};
141 my $rv = $self->$method or print loc("
142 There was an error setting up this section. You might want to try again
145 ### was it save & exit?
146 if( $choice eq $save and $rv ) {
148 Quitting setup, changes are saved to '%1'
149 ", $self->config_type
154 ### otherwise, present choice again
163 ### sub that figures out what kind of config type the user wants
166 my $term = $self->term;
167 my $conf = $self->configure_object;
173 Where would you like to save your CPANPLUS Configuration file?
175 If you want to configure CPANPLUS for this user only,
176 select the '%1' option.
177 The file will then be saved in your homedirectory.
179 If you are the system administrator of this machine,
180 and would like to make this config available globally,
181 select the '%2' option.
182 The file will be then be saved in your CPANPLUS
183 installation directory.
185 ], CONFIG_USER, CONFIG_SYSTEM );
188 ### ask what config type we should save to
189 my $type = $term->get_reply(
190 prompt => loc("Type of configuration file"),
191 default => $self->config_type || CONFIG_USER,
192 choices => [CONFIG_USER, CONFIG_SYSTEM],
195 my $file = $conf->_config_pm_to_file( $type );
197 ### can we save to this file?
198 unless( $conf->can_save( $file ) ) {
200 "Can not save to file '%1'-- please check permissions " .
201 "and try again", $file
204 redo ASK_CONFIG_FILE;
207 ### you already have the file -- are we allowed to overwrite
208 ### or should we try again?
209 if ( -e $file and -w _ ) {
211 I see you already have this file:
214 The file will not be overwritten until you explicitly save it.
219 unless $term->ask_yn(
220 prompt => loc( "Do you wish to use this file?"),
225 print $/, loc("Using '%1' as your configuration type", $type);
227 return $self->config_type($type);
232 ### setup the build & cache dirs
235 my $term = $self->term;
236 my $conf = $self->configure_object;
238 my $base = $conf->get_conf('base');
239 my $home = File::Spec->catdir( $self->_home_dir, DOT_CPANPLUS );
242 CPANPLUS needs a directory of its own to cache important index
243 files and maybe keep a temporary mirror of CPAN files.
244 This may be a site-wide directory or a personal directory.
246 For a single-user installation, we suggest using your home directory.
252 my $other = loc('Somewhere else');
253 if( $base and ($base ne $home) ) {
254 print loc("You have several choices:");
256 $where = $term->get_reply(
257 prompt => loc('Please pick one'),
258 choices => [$home, $base, $other],
265 if( $where and -d $where ) {
267 I see you already have a directory:
272 my $yn = $term->ask_yn(
273 prompt => loc('Should I use it?'),
276 $where = '' unless $yn;
279 if( $where and ($where ne $other) and not -d $where ) {
280 if (!$self->_mkdir( dir => $where ) ) {
281 print "\n", loc("Unable to create directory '%1'", $where);
285 } elsif( not $where or ($where eq $other) ) {
287 First of all, I'd like to create this directory.
292 $where = $term->get_reply(
293 prompt => loc('Where shall I create it?'),
298 if( -d $where and not -w _ ) {
299 print "\n", loc("I can't seem to write in this directory");
301 } elsif (!$self->_mkdir( dir => $where ) ) {
302 print "\n", loc("Unable to create directory '%1'", $where);
307 print "\n", loc('Please select another directory'), "\n\n";
314 ### tidy up the path and store it
315 $where = File::Spec->rel2abs($where);
316 $conf->set_conf( base => $where );
318 ### create subdirectories ###
320 File::Spec->catdir( $where, $self->_perl_version(perl => $^X),
321 $conf->_get_build('moddir') ),
323 File::Spec->catdir( $where, $conf->_get_build($_) )
324 } qw[autdir distdir];
326 for my $dir ( @dirs ) {
327 unless( $self->_mkdir( dir => $dir ) ) {
328 warn loc("I wasn't able to create '%1'", $dir), "\n";
332 ### clear away old storable images before 0.031
333 for my $src (qw[dslip mailrc packages]) {
334 1 while unlink File::Spec->catfile( $where, $src );
339 Your CPANPLUS build and cache directory has been set to:
349 my $term = $self->term;
350 my $conf = $self->configure_object;
352 #########################
353 ## are you a pacifist? ##
354 #########################
357 If you are connecting through a firewall or proxy that doesn't handle
358 FTP all that well you can use passive FTP.
362 my $yn = $term->ask_yn(
363 prompt => loc("Use passive FTP?"),
364 default => $conf->get_conf('passive'),
367 $conf->set_conf(passive => $yn);
369 ### set the ENV var as well, else it won't get set till AFTER
370 ### the configuration is saved. but we fetch files BEFORE that.
371 $ENV{FTP_PASSIVE} = $yn;
375 ? loc("I will use passive FTP.")
376 : loc("I won't use passive FTP.");
379 #############################
380 ## should fetches timeout? ##
381 #############################
384 CPANPLUS can specify a network timeout for downloads (in whole seconds).
385 If none is desired (or to skip this question), enter '0'.
389 my $timeout = 0 + $term->get_reply(
390 prompt => loc("Network timeout for downloads"),
391 default => $conf->get_conf('timeout') || 0,
392 allow => qr/(?!\D)/, ### whole numbers only
395 $conf->set_conf(timeout => $timeout);
399 ? loc("The network timeout for downloads is %1 seconds.", $timeout)
400 : loc("The network timeout for downloads is not set.");
403 ############################
404 ## where can I reach you? ##
405 ############################
408 What email address should we send as our anonymous password when
409 fetching modules from CPAN servers? Some servers will NOT allow you to
410 connect without a valid email address, or at least something that looks
412 Also, if you choose to report test results at some point, a valid email
413 is required for the 'from' field, so choose wisely.
417 my $other = 'Something else';
418 my @choices = (DEFAULT_EMAIL, $Config{cf_email}, $other);
419 my $current = $conf->get_conf('email');
421 ### if your current address is not in the list, add it to the choices
422 unless (grep { $_ eq $current } @choices) {
423 unshift @choices, $current;
426 my $email = $term->get_reply(
427 prompt => loc('Which email address shall I use?'),
428 default => $current || $choices[0],
429 choices => \@choices,
432 if( $email eq $other ) {
434 $email = $term->get_reply(
435 prompt => loc('Email address: '),
438 unless( $self->_valid_email($email) ) {
440 You did not enter a valid email address, please try again!
454 $conf->set_conf( email => $email );
460 ### commandline programs
463 my $term = $self->term;
464 my $conf = $self->configure_object;
467 CPANPLUS can use command line utilities to do certain
468 tasks, rather than use perl modules.
470 If you wish to use a certain command utility, just enter
471 the full path (or accept the default). If you do not wish
472 to use it, enter a single space.
474 Note that the paths you provide should not contain spaces, which is
475 needed to make a distinction between program name and options to that
476 program. For Win32 machines, you can use the short name for a path,
478 ", 'c:\Progra~1\prog.exe' );
480 for my $prog ( sort $conf->options( type => 'program') ) {
482 print "\n", loc("Where can I find your '%1' utility? ".
483 "(Enter a single space to disable)", $prog ), "\n";
485 my $loc = $term->get_reply(
486 prompt => "Path to your '$prog'",
487 default => $conf->get_program( $prog ),
490 ### empty line clears it
491 my $cmd = $loc =~ /^\s*$/ ? undef : $loc;
492 my ($bin) = $cmd =~ /^(\S+)/;
494 ### did you provide a valid program ?
495 if( $bin and not can_run( $bin ) ) {
497 print loc("Can not find the binary '%1' in your path!", $bin);
501 ### make is special -- we /need/ it!
502 if( $prog eq 'make' and not $bin ) {
504 "==> Without your '%1' utility, I can not function! <==",
507 print loc("Please provide one!");
509 ### show win32 where to download
510 if ( $^O eq 'MSWin32' ) {
511 print loc("You can get '%1' from:", NMAKE);
512 print "\t". NMAKE_URL ."\n";
518 $conf->set_program( $prog => $cmd );
520 ? loc( "Your '%1' utility has been set to '%2'.",
522 : loc( "Your '%1' has been disabled.", $prog );
530 sub _setup_installer {
532 my $term = $self->term;
533 my $conf = $self->configure_object;
538 CPANPLUS uses binary programs as well as Perl modules to accomplish
539 various tasks. Normally, CPANPLUS will prefer the use of Perl modules
540 over binary programs.
542 You can change this setting by making CPANPLUS prefer the use of
543 certain binary programs if they are available.
547 ### default to using binaries if we don't have compress::zlib only
548 ### -- it'll get very noisy otherwise
549 my $type = 'prefer_bin';
550 my $yn = $term->ask_yn(
551 prompt => loc("Should I prefer the use of binary programs?"),
552 default => $conf->get_conf( $type ),
556 ? loc("Ok, I will prefer to use binary programs if possible.")
557 : loc("Ok, I will prefer to use Perl modules if possible.");
561 $conf->set_conf( $type => $yn );
566 Makefile.PL is run by perl in a separate process, and accepts various
567 flags that controls the module's installation. For instance, if you
568 would like to install modules to your private user directory, set
571 LIB=~/perl/lib INSTALLMAN1DIR=~/perl/man/man1 INSTALLMAN3DIR=~/perl/man/man3
573 and be sure that you do NOT set UNINST=1 in 'makeflags' below.
575 Enter a name=value list separated by whitespace, but quote any embedded
576 spaces that you want to preserve. (Enter a space to clear any existing
579 If you don't understand this question, just press ENTER.
583 my $type = 'makemakerflags';
584 my $flags = $term->get_reply(
585 prompt => 'Makefile.PL flags?',
586 default => $conf->get_conf($type),
589 $flags = '' if $flags eq $none || $flags !~ /\S/;
591 print "\n", loc("Your '%1' have been set to:", 'Makefile.PL flags'),
592 "\n ", ( $flags ? $flags : loc('*nothing entered*')),
595 $conf->set_conf( $type => $flags );
600 Like Makefile.PL, we run 'make' and 'make install' as separate processes.
601 If you have any parameters (e.g. '-j3' in dual processor systems) you want
602 to pass to the calls, please specify them here.
604 In particular, 'UNINST=1' is recommended for root users, unless you have
605 fine-tuned ideas of where modules should be installed in the \@INC path.
607 Enter a name=value list separated by whitespace, but quote any embedded
608 spaces that you want to preserve. (Enter a space to clear any existing
611 Again, if you don't understand this question, just press ENTER.
614 my $type = 'makeflags';
615 my $flags = $term->get_reply(
616 prompt => 'make flags?',
617 default => $conf->get_conf($type),
620 $flags = '' if $flags eq $none || $flags !~ /\S/;
622 print "\n", loc("Your '%1' have been set to:", $type),
623 "\n ", ( $flags ? $flags : loc('*nothing entered*')),
626 $conf->set_conf( $type => $flags );
631 An alternative to ExtUtils::MakeMaker and Makefile.PL there's a module
632 called Module::Build which uses a Build.PL.
634 If you would like to specify any flags to pass when executing the
635 Build.PL (and Build) script, please enter them below.
637 For instance, if you would like to install modules to your private
638 user directory, you could enter:
640 install_base=/my/private/path
642 Or to uninstall old copies of modules before updating, you might
647 Again, if you don't understand this question, just press ENTER.
651 my $type = 'buildflags';
652 my $flags = $term->get_reply(
653 prompt => 'Build.PL and Build flags?',
654 default => $conf->get_conf($type),
657 $flags = '' if $flags eq $none || $flags !~ /\S/;
659 print "\n", loc("Your '%1' have been set to:",
660 'Build.PL and Build flags'),
661 "\n ", ( $flags ? $flags : loc('*nothing entered*')),
664 $conf->set_conf( $type => $flags );
667 ### use EU::MM or module::build? ###
670 Some modules provide both a Build.PL (Module::Build) and a Makefile.PL
671 (ExtUtils::MakeMaker). By default, CPANPLUS prefers Makefile.PL.
673 Module::Build support is not bundled standard with CPANPLUS, but
674 requires you to install 'CPANPLUS::Dist::Build' from CPAN.
676 Although Module::Build is a pure perl solution, which means you will
677 not need a 'make' binary, it does have some limitations. The most
678 important is that CPANPLUS is unable to uninstall any modules installed
681 Again, if you don't understand this question, just press ENTER.
684 my $type = 'prefer_makefile';
685 my $yn = $term->ask_yn(
686 prompt => loc("Prefer Makefile.PL over Build.PL?"),
687 default => $conf->get_conf($type),
690 $conf->set_conf( $type => $yn );
695 If you like, CPANPLUS can add extra directories to your @INC list during
696 startup. These will just be used by CPANPLUS and will not change your
697 external environment or perl interpreter. Enter a space separated list of
698 pathnames to be added to your @INC, quoting any with embedded whitespace.
699 (To clear the current value enter a single space.)
704 my $flags = $term->get_reply(
705 prompt => loc('Additional @INC directories to add?'),
706 default => (join " ", @{$conf->get_conf($type) || []} ),
710 unless( $flags =~ /\S/ ) {
713 (@$lib) = $flags =~ m/\s*("[^"]+"|'[^']+'|[^\s]+)/g;
716 print "\n", loc("Your additional libs are now:"), "\n";
719 ? map { " $_\n" } @$lib
720 : " ", loc("*nothing entered*"), "\n";
723 $conf->set_conf( $type => $lib );
732 my $term = $self->term;
733 my $conf = $self->configure_object;
742 In normal operation I can just give you basic information about what I
743 am doing, or I can be more verbose and give you every little detail.
747 my $type = 'verbose';
748 my $yn = $term->ask_yn(
749 prompt => loc("Should I be verbose?"),
750 default => $conf->get_conf( $type ), );
754 ? loc("You asked for it!")
755 : loc("I'll try to be quiet");
757 $conf->set_conf( $type => $yn );
761 #######################
762 ## flush you animal! ##
763 #######################
766 In the interest of speed, we keep track of what modules were installed
767 successfully and which failed in the current session. We can flush this
768 data automatically, or you can explicitly issue a 'flush' when you want
774 my $yn = $term->ask_yn(
775 prompt => loc("Flush automatically?"),
776 default => $conf->get_conf( $type ),
781 ? loc("I'll flush after every full module install.")
782 : loc("I won't flush until you tell me to.");
784 $conf->set_conf( $type => $yn );
788 #####################
789 ## force installs? ##
790 #####################
793 Usually, when a test fails, I won't install the module, but if you
794 prefer, I can force the install anyway.
799 my $yn = $term->ask_yn(
800 prompt => loc("Force installs?"),
801 default => $conf->get_conf( $type ),
806 ? loc("I will force installs.")
807 : loc("I won't force installs.");
809 $conf->set_conf( $type => $yn );
818 Sometimes a module will require other modules to be installed before it
819 will work. CPANPLUS can attempt to install these for you automatically
820 if you like, or you can do the deed yourself.
822 If you would prefer that we NEVER try to install extra modules
823 automatically, select NO. (Usually you will want this set to YES.)
825 If you would like to build modules to satisfy testing or prerequisites,
826 but not actually install them, select BUILD.
828 NOTE: This feature requires you to flush the 'lib' cache for longer
829 running programs (refer to the CPANPLUS::Backend documentations for
832 Otherwise, select ASK to have us ask your permission to install them.
836 my $type = 'prereqs';
839 [ PREREQ_IGNORE, # conf value
840 loc('No, do not install prerequisites'), # UI Value
841 loc("I won't install prerequisites") # diag message
844 loc('Yes, please install prerequisites'),
845 loc("I will install prerequisites")
848 loc('Ask me before installing a prerequisite'),
849 loc("I will ask permission to install")
852 loc('Build prerequisites, but do not install them'),
853 loc( "I will only build, but not install prerequisites" )
857 my %reply = map { $_->[1] => $_->[0] } @map; # choice => value
858 my %diag = map { $_->[1] => $_->[2] } @map; # choice => diag message
859 my %conf = map { $_->[0] => $_->[1] } @map; # value => ui choice
861 my $reply = $term->get_reply(
862 prompt => loc('Follow prerequisites?'),
863 default => $conf{ $conf->get_conf( $type ) },
864 choices => [ @conf{ sort keys %conf } ],
868 my $value = $reply{ $reply };
869 my $diag = $diag{ $reply };
871 $conf->set_conf( $type => $value );
876 Modules in the CPAN archives are protected with md5 checksums.
878 This requires the Perl module Digest::MD5 to be installed (which
879 CPANPLUS can do for you later);
884 my $yn = $term->ask_yn(
885 prompt => loc("Shall I use the MD5 checksums?"),
886 default => $conf->get_conf( $type ),
890 ? loc("I will use the MD5 checksums if you have it")
891 : loc("I won't use the MD5 checksums");
893 $conf->set_conf( $type => $yn );
898 { ###########################################
899 ## sally sells seashells by the seashore ##
900 ###########################################
903 By default CPANPLUS uses its own shell when invoked. If you would prefer
904 a different shell, such as one you have written or otherwise acquired,
905 please enter the full name for your shell module.
911 my @choices = (qw| CPANPLUS::Shell::Default
912 CPANPLUS::Shell::Classic |,
914 my $default = $conf->get_conf($type);
916 unshift @choices, $default unless grep { $_ eq $default } @choices;
918 my $reply = $term->get_reply(
919 prompt => loc('Which CPANPLUS shell do you want to use?'),
921 choices => \@choices,
924 if( $reply eq $other ) {
926 $reply = $term->get_reply(
927 prompt => loc( 'Please enter the name of the shell '.
928 'you wish to use: '),
931 unless( check_install( module => $reply ) ) {
933 loc("Could not find '$reply' in your path " .
934 "-- please try again"),
941 print "\n", loc("Your shell is now: %1", $reply), "\n\n";
943 $conf->set_conf( $type => $reply );
952 To speed up the start time of CPANPLUS, and maintain a cache over
953 multiple runs, we can use Storable to freeze some information.
954 Would you like to do this?
957 my $type = 'storable';
958 my $yn = $term->ask_yn(
959 prompt => loc("Use Storable?"),
960 default => $conf->get_conf( $type ) ? 1 : 0,
964 ? loc("I will use Storable if you have it")
965 : loc("I will not use Storable");
967 $conf->set_conf( $type => $yn );
977 To limit the amount of RAM used by CPANPLUS, you can use the SQLite
978 source backend instead. Note that it is currently still experimental.
979 Would you like to do this?
982 my $type = 'source_engine';
983 my $class = 'CPANPLUS::Internals::Source::SQLite';
984 my $yn = $term->ask_yn(
985 prompt => loc("Use SQLite?"),
986 default => $conf->get_conf( $type ) eq $class ? 1 : 0,
990 ? loc("I will use SQLite")
991 : loc("I will not use SQLite");
993 $conf->set_conf( $type => $class );
1002 CPANPLUS has support for the Test::Reporter module, which can be utilized
1003 to report success and failures of modules installed by CPANPLUS. Would
1004 you like to do this? Note that you will still be prompted before
1005 sending each report.
1007 If you don't have all the required modules installed yet, you should
1008 consider installing '%1'
1010 This package bundles all the required modules to enable test reporting
1011 and querying from CPANPLUS.
1012 You can do so straight after this installation.
1014 ", 'Bundle::CPANPLUS::Test::Reporter');
1016 my $type = 'cpantest';
1017 my $yn = $term->ask_yn(
1018 prompt => loc('Report test results?'),
1019 default => $conf->get_conf( $type ) ? 1 : 0,
1024 ? loc("I will prompt you to report test results")
1025 : loc("I won't prompt you to report test results");
1027 $conf->set_conf( $type => $yn );
1031 ###################################
1032 ## use cryptographic signatures? ##
1033 ###################################
1036 The Module::Signature extension allows CPAN authors to sign their
1037 distributions using PGP signatures. Would you like to check for
1038 module's cryptographic integrity before attempting to install them?
1039 Note that this requires either the 'gpg' utility or Crypt::OpenPGP
1043 my $type = 'signature';
1045 my $yn = $term->ask_yn(
1046 prompt => loc('Shall I check module signatures?'),
1047 default => $conf->get_conf($type) ? 1 : 0,
1052 ? loc("Ok, I will attempt to check module signatures.")
1053 : loc("Ok, I won't attempt to check module signatures.");
1055 $conf->set_conf( $type => $yn );
1063 my $term = $self->term;
1064 my $conf = $self->configure_object;
1067 if( scalar @{ $conf->get_conf('hosts') } ) {
1070 for my $href ( @{$conf->get_conf('hosts')} ) {
1071 $hosts .= "\t$href->{scheme}://$href->{host}$href->{path}\n";
1075 I see you already have some hosts selected:
1079 If you'd like to stick with your current settings, just select 'Yes'.
1080 Otherwise, select 'No' and you can reconfigure your hosts
1083 my $yn = $term->ask_yn(
1084 prompt => loc("Would you like to keep your current hosts?"),
1094 Now we need to know where your favorite CPAN sites are located. Make a
1095 list of a few sites (just in case the first on the array won't work).
1097 If you are mirroring CPAN to your local workstation, specify a file:
1098 URI by picking the CUSTOM option.
1100 Otherwise, let us fetch the official CPAN mirror list and you can pick
1101 the mirror that suits you best from a list by using the MIRROR option;
1102 First, pick a nearby continent and country. Then, you will be presented
1103 with a list of URLs of CPAN mirrors in the country you selected. Select
1104 one or more of those URLs.
1106 Note, the latter option requires a working net connection.
1108 You can select VIEW to see your current selection and QUIT when you
1113 my $reply = $term->get_reply(
1114 prompt => loc('Please choose an option'),
1115 choices => [qw|Mirror Custom View Quit|],
1116 default => 'Mirror',
1119 goto MIRROR if $reply eq 'Mirror';
1120 goto CUSTOM if $reply eq 'Custom';
1121 goto QUIT if $reply eq 'Quit';
1123 $self->_view_hosts(@hosts) if $reply eq 'View';
1130 $mirror_file ||= $self->_get_mirrored_by or return;
1131 $hosts ||= $self->_parse_mirrored_by($mirror_file) or return;
1133 my ($continent, $country, $host) = $self->_guess_from_timezone( $hosts );
1137 my @choices = sort map {
1140 not $seen{$_->{'continent'}}++
1142 push @choices, qw[Custom Up Quit];
1144 my $reply = $term->get_reply(
1145 prompt => loc('Pick a continent'),
1146 default => $continent,
1147 choices => \@choices,
1150 goto MAIN if $reply eq 'Up';
1151 goto CUSTOM if $reply eq 'Custom';
1152 goto QUIT if $reply eq 'Quit';
1154 $continent = $reply;
1159 my @choices = sort map {
1162 not $seen{$_->{'country'}}++
1164 ($_->{'continent'} eq $continent)
1166 push @choices, qw[Custom Up Quit];
1168 my $reply = $term->get_reply(
1169 prompt => loc('Pick a country'),
1170 default => $country,
1171 choices => \@choices,
1174 goto CONTINENT if $reply eq 'Up';
1175 goto CUSTOM if $reply eq 'Custom';
1176 goto QUIT if $reply eq 'Quit';
1183 $_->{'continent'} eq $continent and
1184 $_->{'country'} eq $country
1187 my %map; my $default;
1188 for my $href (@list) {
1189 for my $con ( @{$href->{'connections'}} ) {
1190 next unless length $con->{'host'};
1192 my $entry = $con->{'scheme'} . '://' . $con->{'host'};
1193 $default = $entry if $con->{'host'} eq $host;
1195 $map{$entry} = $con;
1201 ### doesn't play nice with Term::UI :(
1202 ### should make t::ui figure out pager opens
1203 #$self->_pager_open; # host lists might be long
1206 You can enter multiple sites by seperating them by a space.
1211 my @reply = $term->get_reply(
1212 prompt => loc('Please pick a site: '),
1213 choices => [sort(keys %map),
1214 qw|Custom View Up Quit|],
1215 default => $default,
1218 #$self->_pager_close;
1221 goto COUNTRY if grep { $_ eq 'Up' } @reply;
1222 goto CUSTOM if grep { $_ eq 'Custom' } @reply;
1223 goto QUIT if grep { $_ eq 'Quit' } @reply;
1225 ### add the host, but only if it's not on the stack already ###
1226 unless( grep { $_ eq 'View' } @reply ) {
1227 for my $reply (@reply) {
1228 if( grep { $_ eq $map{$reply} } @hosts ) {
1229 print loc("Host '%1' already selected", $reply);
1232 push @hosts, $map{$reply}
1237 $self->_view_hosts(@hosts);
1239 goto QUIT if $self->autoreply;
1247 If there are any additional URLs you would like to use, please add them
1248 now. You may enter them separately or as a space delimited list.
1250 We provide a default fall-back URL, but you are welcome to override it
1251 with e.g. 'http://www.cpan.org/' if LWP, wget or curl is installed.
1253 (Enter a single space when you are done, or to simply skip this step.)
1255 Note that if you want to use a local depository, you will have to enter
1258 file://server/path/to/cpan
1260 if the file is on a server on your local network or as:
1262 file:///path/to/cpan
1264 if the file is on your local disk. Note the three /// after the file: bit
1269 my $reply = $term->get_reply(
1270 prompt => loc("Additionals host(s) to add: "),
1274 last CHOICE unless $reply =~ /\S/;
1276 my $href = $self->_parse_host($reply);
1281 $href->{'scheme'} eq $_->{'scheme'} and
1282 $href->{'host'} eq $_->{'host'} and
1283 $href->{'path'} eq $_->{'path'}
1286 last CHOICE if $self->autoreply;
1288 print loc("Invalid uri! Please try again!");
1291 $self->_view_hosts(@hosts);
1299 Where would you like to go now?
1301 Please pick one of the following options or Quit when you are done
1304 my $answer = $term->get_reply(
1305 prompt => loc("Where to now?"),
1307 choices => [qw|Mirror Custom View Quit|],
1310 if( $answer eq 'View' ) {
1311 $self->_view_hosts(@hosts);
1315 goto MIRROR if $answer eq 'Mirror';
1316 goto CUSTOM if $answer eq 'Custom';
1317 goto QUIT if $answer eq 'Quit';
1322 $conf->set_conf( hosts => \@hosts );
1325 Your host configuration has been saved
1339 if( scalar @hosts ) {
1341 for my $host (@hosts) {
1343 ### show full path on file uris, otherwise, just show host
1344 my $path = join '', (
1345 $host->{'scheme'} eq 'file'
1346 ? ( ($host->{'host'} || '[localhost]'),
1351 printf "%-40s %30s\n",
1352 loc("Selected %1",$host->{'scheme'} . '://' . $path ),
1353 loc("%quant(%2,host) selected thus far.", $i);
1357 print loc("No hosts selected so far.");
1365 sub _get_mirrored_by {
1367 my $cpan = $self->backend;
1368 my $conf = $self->configure_object;
1371 Now, we are going to fetch the mirror list for first-time configurations.
1372 This may take a while...
1376 ### use the enew configuratoin ###
1377 $cpan->configure_object( $conf );
1379 load CPANPLUS::Module::Fake;
1380 load CPANPLUS::Module::Author::Fake;
1382 my $mb = CPANPLUS::Module::Fake->new(
1383 module => $conf->_get_source('hosts'),
1385 package => $conf->_get_source('hosts'),
1386 author => CPANPLUS::Module::Author::Fake->new(
1387 _id => $cpan->_id ),
1391 my $file = $cpan->_fetch( fetchdir => $conf->get_conf('base'),
1394 return $file if $file;
1398 sub _parse_mirrored_by {
1404 my $fh = new FileHandle;
1407 warn(loc('Could not open file "%1": %2', $file, $!)),
1411 ### slurp the file in ###
1412 { local $/; $file = <$fh> }
1414 ### remove comments ###
1415 $file =~ s/#.*$//gm;
1419 ### sample host entry ###
1421 # frequency = "daily"
1422 # dst_ftp = "ftp://ftp.sun.ac.za/CPAN/CPAN/"
1423 # dst_location = "Stellenbosch, South Africa, Africa (-26.1992 28.0564)"
1424 # dst_organisation = "University of Stellenbosch"
1425 # dst_timezone = "+2"
1426 # dst_contact = "ftpadm@ftp.sun.ac.za"
1427 # dst_src = "ftp.funet.fi"
1429 # # dst_dst = "ftp://ftp.sun.ac.za/CPAN/CPAN/"
1430 # # dst_contact = "mailto:ftpadm@ftp.sun.ac.za
1431 # # dst_src = "ftp.funet.fi"
1433 ### host name as key, rest of the entry as value ###
1434 my %hosts = $file =~ m/([a-zA-Z0-9\-\.]+):\s+((?:\w+\s+=\s+".*?"\s+)+)/gs;
1436 while (my($host,$data) = each %hosts) {
1441 my @a = split /\s*=\s*/;
1442 $a[1] =~ s/^"(.+?)"$/$1/g;
1443 $href->{ pop @a } = pop @a;
1444 } grep /\S/, split /\n/, $data;
1446 ($href->{city_area}, $href->{country}, $href->{continent},
1447 $href->{latitude}, $href->{longitude} ) =
1448 $href->{dst_location} =~
1450 #Aizu-Wakamatsu, Tohoku-chiho, Fukushima
1452 (?:[^,]+?)\s* # city
1454 (?:,\s*[^,]+?)\s* # optional area
1455 )*? # some have multiple areas listed
1459 ,\s*([^,]+?)\s* # country
1462 ,\s*([^,]+?)\s* # continent
1464 # (37.4333 139.9821)
1465 \((\S+)\s+(\S+?)\)"?$ # (latitude longitude)
1468 ### parse the different hosts, store them in config format ###
1471 for my $type (qw[dst_ftp dst_rsync dst_http]) {
1472 my $path = $href->{$type};
1473 next unless $path =~ /\w/;
1474 if ($type eq 'dst_rsync' && $path !~ /^rsync:/) {
1476 $path = "rsync://$path/";
1478 my $parts = $self->_parse_host($path);
1482 $href->{connections} = \@list;
1483 $hosts{$host} = $href;
1493 my @parts = $host =~ m|^(\w*)://([^/]*)(/.*)$|s;
1496 for my $key (qw[scheme host path]) {
1497 $href->{$key} = shift @parts;
1500 return if lc($href->{'scheme'}) ne 'file' and !$href->{'host'};
1501 return if !$href->{'path'};
1506 ## tries to figure out close hosts based on your timezone
1508 ## Currently can only report on unique items for each of zones, countries, and
1509 ## sites. In the future this will be combined with something else (perhaps a
1510 ## ping?) to narrow down multiple choices.
1512 ## Tries to return the best zone, country, and site for your location. Any non-
1513 ## unique items will be set to undef instead.
1515 ## (takes hashref, returns array)
1517 sub _guess_from_timezone {
1520 my (%zones, %countries, %sites);
1522 ### autrijus - build time zone table
1525 '4 times a day' => 400,
1528 'twice daily' => 50,
1532 while (my ($site, $host) = each %{$hosts}) {
1533 my ($zone, $continent, $country, $frequency) =
1534 @{$host}{qw/dst_timezone continent country frequency/};
1537 # skip non-well-formed ones
1538 next unless $continent and $country and $zone =~ /^[-+]?\d+(?::30)?/;
1545 $zones{$zone}{$continent}++;
1546 $countries{$zone}{$continent}{$country}++;
1547 $sites{$zone}{$continent}{$country}{$site} = $freq_weight{$frequency};
1551 my $offset = ((timegm(localtime) - timegm(gmtime)) / 3600);
1555 ## pick the entry with most country/site/frequency, one level each;
1556 ## note it has to be sorted -- otherwise we're depending on the hash order.
1557 ## also, the list context assignment (pick first one) is deliberate.
1559 my ($continent) = map {
1560 (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
1563 my ($country) = map {
1564 (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
1565 } $countries{$offset}{$continent};
1568 (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
1569 } $sites{$offset}{$continent}{$country};
1571 return ($continent, $country, $site);
1572 } # _guess_from_timezone
1575 ### big big regex, stolen to check if you enter a valid address
1577 my $RFC822PAT; # RFC pattern to match for valid email address
1582 my $esc = '\\\\'; my $Period = '\.'; my $space = '\040';
1583 my $tab = '\t'; my $OpenBR = '\['; my $CloseBR = '\]';
1584 my $OpenParen = '\('; my $CloseParen = '\)'; my $NonASCII = '\x80-\xff';
1585 my $ctrl = '\000-\037'; my $CRlist = '\012\015';
1587 my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
1588 my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
1589 my $quoted_pair = qq< $esc [^$NonASCII] >; # an escaped character
1590 my $ctext = qq< [^$esc$NonASCII$CRlist()] >;
1591 my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >;
1592 my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >;
1593 my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >;
1594 my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
1595 my $atom = qq< $atom_char+ (?!$atom_char) >;
1596 my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >;
1597 my $word = qq< (?: $atom | $quoted_str ) >;
1598 my $domain_ref = $atom;
1599 my $domain_lit = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >;
1600 my $sub_domain = qq< (?: $domain_ref | $domain_lit) $X >;
1601 my $domain = qq< $sub_domain (?: $Period $X $sub_domain)* >;
1602 my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;
1603 my $local_part = qq< $word $X (?: $Period $X $word $X )* >;
1604 my $addr_spec = qq< $local_part \@ $X $domain >;
1605 my $route_addr = qq[ < $X (?: $route )? $addr_spec > ];
1606 my $phrase_ctrl = '\000-\010\012-\037'; # like ctrl, but without tab
1607 my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
1608 my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >;
1609 $RFC822PAT = qq< $X (?: $addr_spec | $phrase $route_addr) >;
1612 return scalar ($_[0] =~ /$RFC822PAT/ox);
1626 my $conf = $self->configure_object;
1627 my $file = shift || $conf->_config_pm_to_file( $self->config_type );
1628 my $editor = shift || $conf->get_program('editor');
1629 my $term = $self->term;
1633 I'm sorry, I can't find a suitable editor, so I can't offer you
1634 post-configuration editing of the config file
1640 ### save the thing first, so there's something to edit
1643 return !system("$editor $file");
1648 my $conf = $self->configure_object;
1650 return $conf->save( $self->config_type );