Re: 5.10.0 test hangs on non internet access
[p5sagit/p5-mst-13.2.git] / lib / CPANPLUS / Configure / Setup.pm
CommitLineData
6aaee015 1package CPANPLUS::Configure::Setup;
2
3use strict;
4use vars qw(@ISA);
5
6use base qw[CPANPLUS::Internals::Utils];
7use base qw[Object::Accessor];
8
9use Config;
10use Term::UI;
11use Module::Load;
12use Term::ReadLine;
13
14
15use CPANPLUS::Internals::Utils;
16use CPANPLUS::Internals::Constants;
17use CPANPLUS::Error;
18
19use IPC::Cmd qw[can_run];
20use Params::Check qw[check];
21use Module::Load::Conditional qw[check_install];
22use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
23
24### silence Term::UI
25$Term::UI::VERBOSE = 0;
26
27#Can't ioctl TIOCGETP: Unknown error
28#Consider installing Term::ReadKey from CPAN site nearby
29# at http://www.perl.com/CPAN
30#Or use
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
34#in your environment.
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/
38
39### setting this var in the meantime to avoid this warning ###
40$ENV{PERL_READLINE_NOWARN} = 1;
41
42
43sub new {
44 my $class = shift;
45 my %hash = @_;
46
47 my $tmpl = {
48 configure_object => { },
49 term => { },
50 backend => { },
51 autoreply => { default => 0, },
52 skip_mirrors => { default => 0, },
53 use_previous => { default => 1, },
54 config_type => { default => CONFIG_USER },
55 };
56
57 my $args = check( $tmpl, \%hash ) or return;
58
59 ### initialize object
60 my $obj = $class->SUPER::new( keys %$tmpl );
61 for my $acc ( $obj->ls_accessors ) {
62 $obj->$acc( $args->{$acc} );
63 }
64
65 ### otherwise there's a circular use ###
66 load CPANPLUS::Configure;
67 load CPANPLUS::Backend;
68
69 $obj->configure_object( CPANPLUS::Configure->new() )
70 unless $obj->configure_object;
71
72 $obj->backend( CPANPLUS::Backend->new( $obj->configure_object ) )
73 unless $obj->backend;
74
75 ### use empty string in case user only has T::R::Stub -- it complains
76 $obj->term( Term::ReadLine->new('') )
77 unless $obj->term;
78
79 ### enable autoreply if that was passed ###
80 $Term::UI::AUTOREPLY = $obj->autoreply;
81
82 return $obj;
83}
84
85sub init {
86 my $self = shift;
87 my $term = $self->term;
88
89 ### default setting, unless changed
90 $self->config_type( CONFIG_USER ) unless $self->config_type;
91
92 my $save = loc('Save & exit');
93 my $exit = loc('Quit without saving');
94 my @map = (
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' ],
105 [ $exit => 1 ],
106 );
107
108 my @keys = map { $_->[0] } @map; # sorted keys
109 my %map = map { @$_ } @map; # lookup hash
110
111 PICK_SECTION: {
112 print loc("
113=================> MAIN MENU <=================
114
115Welcome to the CPANPLUS configuration. Please select which
116parts you wish to configure
117
118Defaults are taken from your current configuration.
119If you would save now, your settings would be written to:
120
121 %1
122
123 ", $self->config_type );
124
125 my $choice = $term->get_reply(
126 prompt => "Section to configure:",
127 choices => \@keys,
128 default => $keys[0]
129 );
130
131 ### exit configuration?
132 if( $choice eq $exit ) {
133 print loc("
134Quitting setup, changes will not be saved.
135 ");
136 return 1;
137 }
138
139 my $method = $map{$choice};
140
141 my $rv = $self->$method or print loc("
142There was an error setting up this section. You might want to try again
143 ");
144
145 ### was it save & exit?
146 if( $choice eq $save and $rv ) {
147 print loc("
148Quitting setup, changes are saved to '%1'
149 ", $self->config_type
150 );
151 return 1;
152 }
153
154 ### otherwise, present choice again
155 redo PICK_SECTION;
156 }
157
158 return 1;
159}
160
161
162
163### sub that figures out what kind of config type the user wants
164sub _save_where {
165 my $self = shift;
166 my $term = $self->term;
167 my $conf = $self->configure_object;
168
169
170 ASK_CONFIG_TYPE: {
171
172 print loc( q[
173Where would you like to save your CPANPLUS Configuration file?
174
175If you want to configure CPANPLUS for this user only,
176select the '%1' option.
177The file will then be saved in your homedirectory.
178
179If you are the system administrator of this machine,
180and would like to make this config available globally,
181select the '%2' option.
182The file will be then be saved in your CPANPLUS
183installation directory.
184
185 ], CONFIG_USER, CONFIG_SYSTEM );
186
187
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],
193 );
194
195 my $file = $conf->_config_pm_to_file( $type );
196
197 ### can we save to this file?
198 unless( $conf->can_save( $file ) ) {
199 error(loc(
200 "Can not save to file '%1'-- please check permissions " .
201 "and try again", $file
202 ));
203
204 redo ASK_CONFIG_FILE;
205 }
206
207 ### you already have the file -- are we allowed to overwrite
208 ### or should we try again?
209 if ( -e $file and -w _ ) {
210 print loc(q[
211I see you already have this file:
212 %1
213
214If you continue & save this file, the previous version will be overwritten.
215
216 ], $file );
217
218 redo ASK_CONFIG_TYPE
219 unless $term->ask_yn(
220 prompt => loc( "Shall I overwrite it?"),
221 default => 'n',
222 );
223 }
224
225 print $/, loc("Using '%1' as your configuration type", $type);
226
227 return $self->config_type($type);
228 }
229}
230
231
232### setup the build & cache dirs
233sub _setup_base {
234 my $self = shift;
235 my $term = $self->term;
236 my $conf = $self->configure_object;
237
238 my $base = $conf->get_conf('base');
239 my $home = File::Spec->catdir( $self->_home_dir, DOT_CPANPLUS );
240
241 print loc("
242CPANPLUS needs a directory of its own to cache important index
243files and maybe keep a temporary mirror of CPAN files.
244This may be a site-wide directory or a personal directory.
245
246For a single-user installation, we suggest using your home directory.
247
248");
249
250 my $where;
251 ASK_HOME_DIR: {
252 my $other = loc('Somewhere else');
253 if( $base and ($base ne $home) ) {
254 print loc("You have several choices:");
255
256 $where = $term->get_reply(
257 prompt => loc('Please pick one'),
258 choices => [$home, $base, $other],
259 default => $home,
260 );
261 } else {
262 $where = $base;
263 }
264
265 if( $where and -d $where ) {
266 print loc("
267I see you already have a directory:
268 %1
269
270 "), $where;
271
272 my $yn = $term->ask_yn(
273 prompt => loc('Should I use it?'),
274 default => 'y',
275 );
276 $where = '' unless $yn;
277 }
278
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);
282 redo ASK_HOME_DIR;
283 }
284
285 } elsif( not $where or ($where eq $other) ) {
286 print loc("
287First of all, I'd like to create this directory.
288
289 ");
290
291 NEW_HOME: {
292 $where = $term->get_reply(
293 prompt => loc('Where shall I create it?'),
294 default => $home,
295 );
296
297 my $again;
298 if( -d $where and not -w _ ) {
299 print "\n", loc("I can't seem to write in this directory");
300 $again++;
301 } elsif (!$self->_mkdir( dir => $where ) ) {
302 print "\n", loc("Unable to create directory '%1'", $where);
303 $again++;
304 }
305
306 if( $again ) {
307 print "\n", loc('Please select another directory'), "\n\n";
308 redo NEW_HOME;
309 }
310 }
311 }
312 }
313
314 ### tidy up the path and store it
315 $where = File::Spec->rel2abs($where);
316 $conf->set_conf( base => $where );
317
318 ### create subdirectories ###
319 my @dirs =
320 File::Spec->catdir( $where, $self->_perl_version(perl => $^X),
321 $conf->_get_build('moddir') ),
322 map {
323 File::Spec->catdir( $where, $conf->_get_build($_) )
324 } qw[autdir distdir];
325
326 for my $dir ( @dirs ) {
327 unless( $self->_mkdir( dir => $dir ) ) {
328 warn loc("I wasn't able to create '%1'", $dir), "\n";
329 }
330 }
331
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 );
335
336 }
337
338 print loc(q[
339Your CPANPLUS build and cache directory has been set to:
340 %1
341
342 ], $where);
343
344 return 1;
345}
346
347sub _setup_ftp {
348 my $self = shift;
349 my $term = $self->term;
350 my $conf = $self->configure_object;
351
352 #########################
353 ## are you a pacifist? ##
354 #########################
355
356 print loc("
357If you are connecting through a firewall or proxy that doesn't handle
358FTP all that well you can use passive FTP.
359
360");
361
362 my $yn = $term->ask_yn(
363 prompt => loc("Use passive FTP?"),
364 default => $conf->get_conf('passive'),
365 );
366
367 $conf->set_conf(passive => $yn);
368
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;
372
373 print "\n";
374 print $yn
375 ? loc("I will use passive FTP.")
376 : loc("I won't use passive FTP.");
377 print "\n";
378
379 #############################
380 ## should fetches timeout? ##
381 #############################
382
383 print loc("
384CPANPLUS can specify a network timeout for downloads (in whole seconds).
385If none is desired (or to skip this question), enter '0'.
386
387");
388
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
393 );
394
395 $conf->set_conf(timeout => $timeout);
396
397 print "\n";
398 print $timeout
399 ? loc("The network timeout for downloads is %1 seconds.", $timeout)
400 : loc("The network timeout for downloads is not set.");
401 print "\n";
402
403 ############################
404 ## where can I reach you? ##
405 ############################
406
407 print loc("
408What email address should we send as our anonymous password when
409fetching modules from CPAN servers? Some servers will NOT allow you to
410connect without a valid email address, or at least something that looks
411like one.
412Also, if you choose to report test results at some point, a valid email
413is required for the 'from' field, so choose wisely.
414
415 ");
416
417 my $other = 'Something else';
418 my @choices = (DEFAULT_EMAIL, $Config{cf_email}, $other);
419 my $current = $conf->get_conf('email');
420
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;
424 }
425
426 my $email = $term->get_reply(
427 prompt => loc('Which email address shall I use?'),
428 default => $current || $choices[0],
429 choices => \@choices,
430 );
431
432 if( $email eq $other ) {
433 EMAIL: {
434 $email = $term->get_reply(
435 prompt => loc('Email address: '),
436 );
437
438 unless( $self->_valid_email($email) ) {
439 print loc("
440You did not enter a valid email address, please try again!
441 ") if length $email;
442
443 redo EMAIL;
444 }
445 }
446 }
447
448 print loc("
449Your 'email' is now:
450 %1
451
452 ", $email);
453
454 $conf->set_conf( email => $email );
455
456 return 1;
457}
458
459
460### commandline programs
461sub _setup_program {
462 my $self = shift;
463 my $term = $self->term;
464 my $conf = $self->configure_object;
465
466 print loc("
467CPANPLUS can use command line utilities to do certain
468tasks, rather than use perl modules.
469
470If you wish to use a certain command utility, just enter
471the full path (or accept the default). If you do not wish
472to use it, enter a single space.
473
474Note that the paths you provide should not contain spaces, which is
475needed to make a distinction between program name and options to that
476program. For Win32 machines, you can use the short name for a path,
477like '%1'.
502c7995 478", 'c:\Progra~1\prog.exe' );
6aaee015 479
480 for my $prog ( sort $conf->options( type => 'program') ) {
481 PROGRAM: {
502c7995 482 print "\n", loc("Where can I find your '%1' utility? ".
483 "(Enter a single space to disable)", $prog ), "\n";
6aaee015 484
485 my $loc = $term->get_reply(
486 prompt => "Path to your '$prog'",
487 default => $conf->get_program( $prog ),
488 );
489
490 ### empty line clears it
491 my $cmd = $loc =~ /^\s*$/ ? undef : $loc;
492 my ($bin) = $cmd =~ /^(\S+)/;
493
494 ### did you provide a valid program ?
495 if( $bin and not can_run( $bin ) ) {
496 print "\n";
497 print loc("Can not find the binary '%1' in your path!", $bin);
498 redo PROGRAM;
499 }
500
501 ### make is special -- we /need/ it!
502 if( $prog eq 'make' and not $bin ) {
503 print loc(
504 "==> Without your '%1' utility, I can not function! <==",
505 'make'
506 );
507 print loc("Please provide one!");
508
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";
513 }
514 print "\n";
515 redo PROGRAM;
516 }
517
518 $conf->set_program( $prog => $cmd );
519 print $cmd
502c7995 520 ? loc( "Your '%1' utility has been set to '%2'.",
6aaee015 521 $prog, $cmd )
502c7995 522 : loc( "Your '%1' has been disabled.", $prog );
6aaee015 523 print "\n";
524 }
525 }
526
527 return 1;
528}
529
530sub _setup_installer {
531 my $self = shift;
532 my $term = $self->term;
533 my $conf = $self->configure_object;
534
535 my $none = 'None';
536 {
537 print loc("
538CPANPLUS uses binary programs as well as Perl modules to accomplish
539various tasks. Normally, CPANPLUS will prefer the use of Perl modules
540over binary programs.
541
542You can change this setting by making CPANPLUS prefer the use of
543certain binary programs if they are available.
544
545 ");
546
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 ),
553 );
554
555 print $yn
556 ? loc("Ok, I will prefer to use binary programs if possible.")
557 : loc("Ok, I will prefer to use Perl modules if possible.");
558 print "\n\n";
559
560
561 $conf->set_conf( $type => $yn );
562 }
563
564 {
565 print loc("
566Makefile.PL is run by perl in a separate process, and accepts various
567flags that controls the module's installation. For instance, if you
568would like to install modules to your private user directory, set
569'makemakerflags' to:
570
571LIB=~/perl/lib INSTALLMAN1DIR=~/perl/man/man1 INSTALLMAN3DIR=~/perl/man/man3
572
573and be sure that you do NOT set UNINST=1 in 'makeflags' below.
574
575Enter a name=value list separated by whitespace, but quote any embedded
576spaces that you want to preserve. (Enter a space to clear any existing
577settings.)
578
579If you don't understand this question, just press ENTER.
580
581 ");
582
583 my $type = 'makemakerflags';
584 my $flags = $term->get_reply(
585 prompt => 'Makefile.PL flags?',
586 default => $conf->get_conf($type),
587 );
588
589 $flags = '' if $flags eq $none || $flags !~ /\S/;
590
591 print "\n", loc("Your '%1' have been set to:", 'Makefile.PL flags'),
592 "\n ", ( $flags ? $flags : loc('*nothing entered*')),
593 "\n\n";
594
595 $conf->set_conf( $type => $flags );
596 }
597
598 {
599 print loc("
600Like Makefile.PL, we run 'make' and 'make install' as separate processes.
601If you have any parameters (e.g. '-j3' in dual processor systems) you want
602to pass to the calls, please specify them here.
603
604In particular, 'UNINST=1' is recommended for root users, unless you have
605fine-tuned ideas of where modules should be installed in the \@INC path.
606
607Enter a name=value list separated by whitespace, but quote any embedded
608spaces that you want to preserve. (Enter a space to clear any existing
609settings.)
610
611Again, if you don't understand this question, just press ENTER.
612
613 ");
614 my $type = 'makeflags';
615 my $flags = $term->get_reply(
616 prompt => 'make flags?',
617 default => $conf->get_conf($type),
618 );
619
620 $flags = '' if $flags eq $none || $flags !~ /\S/;
621
622 print "\n", loc("Your '%1' have been set to:", $type),
623 "\n ", ( $flags ? $flags : loc('*nothing entered*')),
624 "\n\n";
625
626 $conf->set_conf( $type => $flags );
627 }
628
629 {
630 print loc("
631An alternative to ExtUtils::MakeMaker and Makefile.PL there's a module
632called Module::Build which uses a Build.PL.
633
634If you would like to specify any flags to pass when executing the
635Build.PL (and Build) script, please enter them below.
636
637For instance, if you would like to install modules to your private
638user directory, you could enter:
639
640 install_base=/my/private/path
641
642Or to uninstall old copies of modules before updating, you might
643want to enter:
644
645 uninst=1
646
647Again, if you don't understand this question, just press ENTER.
648
649 ");
650
651 my $type = 'buildflags';
652 my $flags = $term->get_reply(
653 prompt => 'Build.PL and Build flags?',
654 default => $conf->get_conf($type),
655 );
656
657 $flags = '' if $flags eq $none || $flags !~ /\S/;
658
659 print "\n", loc("Your '%1' have been set to:",
660 'Build.PL and Build flags'),
661 "\n ", ( $flags ? $flags : loc('*nothing entered*')),
662 "\n\n";
663
664 $conf->set_conf( $type => $flags );
665 }
666
667 ### use EU::MM or module::build? ###
668 {
669 print loc("
670Some modules provide both a Build.PL (Module::Build) and a Makefile.PL
671(ExtUtils::MakeMaker). By default, CPANPLUS prefers Makefile.PL.
672
673Module::Build support is not bundled standard with CPANPLUS, but
674requires you to install 'CPANPLUS::Dist::Build' from CPAN.
675
676Although Module::Build is a pure perl solution, which means you will
677not need a 'make' binary, it does have some limitations. The most
678important is that CPANPLUS is unable to uninstall any modules installed
679by Module::Build.
680
681Again, if you don't understand this question, just press ENTER.
682
683 ");
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),
688 );
689
690 $conf->set_conf( $type => $yn );
691 }
692
693 {
694 print loc('
695If you like, CPANPLUS can add extra directories to your @INC list during
696startup. These will just be used by CPANPLUS and will not change your
697external environment or perl interpreter. Enter a space separated list of
698pathnames to be added to your @INC, quoting any with embedded whitespace.
699(To clear the current value enter a single space.)
700
701 ');
702
703 my $type = 'lib';
704 my $flags = $term->get_reply(
705 prompt => loc('Additional @INC directories to add?'),
706 default => (join " ", @{$conf->get_conf($type) || []} ),
707 );
708
709 my $lib;
710 unless( $flags =~ /\S/ ) {
711 $lib = [];
712 } else {
713 (@$lib) = $flags =~ m/\s*("[^"]+"|'[^']+'|[^\s]+)/g;
714 }
715
716 print "\n", loc("Your additional libs are now:"), "\n";
717
718 print scalar @$lib
719 ? map { " $_\n" } @$lib
720 : " ", loc("*nothing entered*"), "\n";
721 print "\n\n";
722
723 $conf->set_conf( $type => $lib );
724 }
725
726 return 1;
727}
728
729
730sub _setup_conf {
731 my $self = shift;
732 my $term = $self->term;
733 my $conf = $self->configure_object;
734
735 my $none = 'None';
736 {
737 ############
738 ## noisy? ##
739 ############
740
741 print loc("
742In normal operation I can just give you basic information about what I
743am doing, or I can be more verbose and give you every little detail.
744
745 ");
746
747 my $type = 'verbose';
748 my $yn = $term->ask_yn(
749 prompt => loc("Should I be verbose?"),
750 default => $conf->get_conf( $type ), );
751
752 print "\n";
753 print $yn
754 ? loc("You asked for it!")
755 : loc("I'll try to be quiet");
756
757 $conf->set_conf( $type => $yn );
758 }
759
760 {
761 #######################
762 ## flush you animal! ##
763 #######################
764
765 print loc("
766In the interest of speed, we keep track of what modules were installed
767successfully and which failed in the current session. We can flush this
768data automatically, or you can explicitly issue a 'flush' when you want
769to purge it.
770
771 ");
772
773 my $type = 'flush';
774 my $yn = $term->ask_yn(
775 prompt => loc("Flush automatically?"),
776 default => $conf->get_conf( $type ),
777 );
778
779 print "\n";
780 print $yn
781 ? loc("I'll flush after every full module install.")
782 : loc("I won't flush until you tell me to.");
783
784 $conf->set_conf( $type => $yn );
785 }
786
787 {
788 #####################
789 ## force installs? ##
790 #####################
791
792 print loc("
793Usually, when a test fails, I won't install the module, but if you
794prefer, I can force the install anyway.
795
796 ");
797
798 my $type = 'force';
799 my $yn = $term->ask_yn(
800 prompt => loc("Force installs?"),
801 default => $conf->get_conf( $type ),
802 );
803
804 print "\n";
805 print $yn
806 ? loc("I will force installs.")
807 : loc("I won't force installs.");
808
809 $conf->set_conf( $type => $yn );
810 }
811
812 {
813 ###################
814 ## about prereqs ##
815 ###################
816
817 print loc("
818Sometimes a module will require other modules to be installed before it
819will work. CPANPLUS can attempt to install these for you automatically
820if you like, or you can do the deed yourself.
821
822If you would prefer that we NEVER try to install extra modules
823automatically, select NO. (Usually you will want this set to YES.)
824
825If you would like to build modules to satisfy testing or prerequisites,
826but not actually install them, select BUILD.
827
828NOTE: This feature requires you to flush the 'lib' cache for longer
829running programs (refer to the CPANPLUS::Backend documentations for
830more details).
831
832Otherwise, select ASK to have us ask your permission to install them.
833
834 ");
835
836 my $type = 'prereqs';
837
838 my @map = (
839 [ PREREQ_IGNORE, # conf value
840 loc('No, do not install prerequisites'), # UI Value
841 loc("I won't install prerequisites") # diag message
842 ],
843 [ PREREQ_INSTALL,
844 loc('Yes, please install prerequisites'),
845 loc("I will install prerequisites")
846 ],
847 [ PREREQ_ASK,
848 loc('Ask me before installing a prerequisite'),
849 loc("I will ask permission to install")
850 ],
851 [ PREREQ_BUILD,
852 loc('Build prerequisites, but do not install them'),
853 loc( "I will only build, but not install prerequisites" )
854 ],
855 );
856
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
860
861 my $reply = $term->get_reply(
862 prompt => loc('Follow prerequisites?'),
863 default => $conf{ $conf->get_conf( $type ) },
864 choices => [ @conf{ sort keys %conf } ],
865 );
866 print "\n";
867
868 my $value = $reply{ $reply };
869 my $diag = $diag{ $reply };
870
871 $conf->set_conf( $type => $value );
872 print $diag, "\n";
873 }
874
875 { print loc("
876Modules in the CPAN archives are protected with md5 checksums.
877
878This requires the Perl module Digest::MD5 to be installed (which
879CPANPLUS can do for you later);
880
881 ");
882 my $type = 'md5';
883
884 my $yn = $term->ask_yn(
885 prompt => loc("Shall I use the MD5 checksums?"),
886 default => $conf->get_conf( $type ),
887 );
888
889 print $yn
890 ? loc("I will use the MD5 checksums if you have it")
891 : loc("I won't use the MD5 checksums");
892
893 $conf->set_conf( $type => $yn );
894
895 }
896
897
898 { ###########################################
899 ## sally sells seashells by the seashore ##
900 ###########################################
901
902 print loc("
903By default CPANPLUS uses its own shell when invoked. If you would prefer
904a different shell, such as one you have written or otherwise acquired,
905please enter the full name for your shell module.
906
907 ");
908
909 my $type = 'shell';
910 my $other = 'Other';
911 my @choices = (qw| CPANPLUS::Shell::Default
912 CPANPLUS::Shell::Classic |,
913 $other );
914 my $default = $conf->get_conf($type);
915
916 unshift @choices, $default unless grep { $_ eq $default } @choices;
917
918 my $reply = $term->get_reply(
919 prompt => loc('Which CPANPLUS shell do you want to use?'),
920 default => $default,
921 choices => \@choices,
922 );
923
924 if( $reply eq $other ) {
925 SHELL: {
926 $reply = $term->get_reply(
927 prompt => loc( 'Please enter the name of the shell '.
928 'you wish to use: '),
929 );
930
931 unless( check_install( module => $reply ) ) {
932 print "\n",
933 loc("Could not find '$reply' in your path " .
934 "-- please try again"),
935 "\n";
936 redo SHELL;
937 }
938 }
939 }
940
941 print "\n", loc("Your shell is now: %1", $reply), "\n\n";
942
943 $conf->set_conf( $type => $reply );
944 }
945
946 {
947 ###################
948 ## use storable? ##
949 ###################
950
951 print loc("
952To speed up the start time of CPANPLUS, and maintain a cache over
953multiple runs, we can use Storable to freeze some information.
954Would you like to do this?
955
956");
957 my $type = 'storable';
958 my $yn = $term->ask_yn(
959 prompt => loc("Use Storable?"),
960 default => $conf->get_conf( $type ) ? 1 : 0,
961 );
962 print "\n";
963 print $yn
964 ? loc("I will use Storable if you have it")
965 : loc("I will not use Storable");
966
967 $conf->set_conf( $type => $yn );
968 }
969
970 {
971 ###################
972 ## use cpantest? ##
973 ###################
974
975 print loc("
976CPANPLUS has support for the Test::Reporter module, which can be utilized
977to report success and failures of modules installed by CPANPLUS. Would
978you like to do this? Note that you will still be prompted before
979sending each report.
980
981If you don't have all the required modules installed yet, you should
982consider installing '%1'
983
984This package bundles all the required modules to enable test reporting
985and querying from CPANPLUS.
986You can do so straight after this installation.
987
988 ", 'Bundle::CPANPLUS::Test::Reporter');
989
990 my $type = 'cpantest';
991 my $yn = $term->ask_yn(
992 prompt => loc('Report test results?'),
993 default => $conf->get_conf( $type ) ? 1 : 0,
994 );
995
996 print "\n";
997 print $yn
998 ? loc("I will prompt you to report test results")
999 : loc("I won't prompt you to report test results");
1000
1001 $conf->set_conf( $type => $yn );
1002 }
1003
1004 {
1005 ###################################
1006 ## use cryptographic signatures? ##
1007 ###################################
1008
1009 print loc("
1010The Module::Signature extension allows CPAN authors to sign their
1011distributions using PGP signatures. Would you like to check for
1012module's cryptographic integrity before attempting to install them?
1013Note that this requires either the 'gpg' utility or Crypt::OpenPGP
1014to be installed.
1015
1016 ");
1017 my $type = 'signature';
1018
1019 my $yn = $term->ask_yn(
1020 prompt => loc('Shall I check module signatures?'),
1021 default => $conf->get_conf($type) ? 1 : 0,
1022 );
1023
1024 print "\n";
1025 print $yn
1026 ? loc("Ok, I will attempt to check module signatures.")
1027 : loc("Ok, I won't attempt to check module signatures.");
1028
1029 $conf->set_conf( $type => $yn );
1030 }
1031
1032 return 1;
1033}
1034
1035sub _setup_hosts {
1036 my $self = shift;
1037 my $term = $self->term;
1038 my $conf = $self->configure_object;
1039
1040
1041 if( scalar @{ $conf->get_conf('hosts') } ) {
1042
1043 my $hosts;
1044 for my $href ( @{$conf->get_conf('hosts')} ) {
1045 $hosts .= "\t$href->{scheme}://$href->{host}$href->{path}\n";
1046 }
1047
1048 print loc("
1049I see you already have some hosts selected:
1050
1051$hosts
1052
1053If you'd like to stick with your current settings, just select 'Yes'.
1054Otherwise, select 'No' and you can reconfigure your hosts
1055
1056");
1057 my $yn = $term->ask_yn(
1058 prompt => loc("Would you like to keep your current hosts?"),
1059 default => 'y',
1060 );
1061 return 1 if $yn;
1062 }
1063
1064 my @hosts;
1065 MAIN: {
1066
1067 print loc("
1068Now we need to know where your favorite CPAN sites are located. Make a
1069list of a few sites (just in case the first on the array won't work).
1070
1071If you are mirroring CPAN to your local workstation, specify a file:
1072URI by picking the CUSTOM option.
1073
1074Otherwise, let us fetch the official CPAN mirror list and you can pick
1075the mirror that suits you best from a list by using the MIRROR option;
1076First, pick a nearby continent and country. Then, you will be presented
1077with a list of URLs of CPAN mirrors in the country you selected. Select
1078one or more of those URLs.
1079
1080Note, the latter option requires a working net connection.
1081
1082You can select VIEW to see your current selection and QUIT when you
1083are done.
1084
1085");
1086
1087 my $reply = $term->get_reply(
1088 prompt => loc('Please choose an option'),
1089 choices => [qw|Mirror Custom View Quit|],
1090 default => 'Mirror',
1091 );
1092
1093 goto MIRROR if $reply eq 'Mirror';
1094 goto CUSTOM if $reply eq 'Custom';
1095 goto QUIT if $reply eq 'Quit';
1096
1097 $self->_view_hosts(@hosts) if $reply eq 'View';
1098 redo MAIN;
1099 }
1100
1101 my $mirror_file;
1102 my $hosts;
1103 MIRROR: {
1104 $mirror_file ||= $self->_get_mirrored_by or return;
1105 $hosts ||= $self->_parse_mirrored_by($mirror_file) or return;
1106
1107 my ($continent, $country, $host) = $self->_guess_from_timezone( $hosts );
1108
1109 CONTINENT: {
1110 my %seen;
1111 my @choices = sort map {
1112 $_->{'continent'}
1113 } grep {
1114 not $seen{$_->{'continent'}}++
1115 } values %$hosts;
1116 push @choices, qw[Custom Up Quit];
1117
1118 my $reply = $term->get_reply(
1119 prompt => loc('Pick a continent'),
1120 default => $continent,
1121 choices => \@choices,
1122 );
1123
1124 goto MAIN if $reply eq 'Up';
1125 goto CUSTOM if $reply eq 'Custom';
1126 goto QUIT if $reply eq 'Quit';
1127
1128 $continent = $reply;
1129 }
1130
1131 COUNTRY: {
1132 my %seen;
1133 my @choices = sort map {
1134 $_->{'country'}
1135 } grep {
1136 not $seen{$_->{'country'}}++
1137 } grep {
1138 ($_->{'continent'} eq $continent)
1139 } values %$hosts;
1140 push @choices, qw[Custom Up Quit];
1141
1142 my $reply = $term->get_reply(
1143 prompt => loc('Pick a country'),
1144 default => $country,
1145 choices => \@choices,
1146 );
1147
1148 goto CONTINENT if $reply eq 'Up';
1149 goto CUSTOM if $reply eq 'Custom';
1150 goto QUIT if $reply eq 'Quit';
1151
1152 $country = $reply;
1153 }
1154
1155 HOST: {
1156 my @list = grep {
1157 $_->{'continent'} eq $continent and
1158 $_->{'country'} eq $country
1159 } values %$hosts;
1160
1161 my %map; my $default;
1162 for my $href (@list) {
1163 for my $con ( @{$href->{'connections'}} ) {
1164 next unless length $con->{'host'};
1165
1166 my $entry = $con->{'scheme'} . '://' . $con->{'host'};
1167 $default = $entry if $con->{'host'} eq $host;
1168
1169 $map{$entry} = $con;
1170 }
1171 }
1172
1173 CHOICE: {
1174
1175 ### doesn't play nice with Term::UI :(
1176 ### should make t::ui figure out pager opens
1177 #$self->_pager_open; # host lists might be long
1178
1179 print loc("
1180You can enter multiple sites by seperating them by a space.
1181For example:
1182 1 4 2 5
1183 ");
1184
1185 my @reply = $term->get_reply(
1186 prompt => loc('Please pick a site: '),
1187 choices => [sort(keys %map),
1188 qw|Custom View Up Quit|],
1189 default => $default,
1190 multi => 1,
1191 );
1192 #$self->_pager_close;
1193
1194
1195 goto COUNTRY if grep { $_ eq 'Up' } @reply;
1196 goto CUSTOM if grep { $_ eq 'Custom' } @reply;
1197 goto QUIT if grep { $_ eq 'Quit' } @reply;
1198
1199 ### add the host, but only if it's not on the stack already ###
1200 unless( grep { $_ eq 'View' } @reply ) {
1201 for my $reply (@reply) {
1202 if( grep { $_ eq $map{$reply} } @hosts ) {
1203 print loc("Host '%1' already selected", $reply);
1204 print "\n\n";
1205 } else {
1206 push @hosts, $map{$reply}
1207 }
1208 }
1209 }
1210
1211 $self->_view_hosts(@hosts);
1212
1213 goto QUIT if $self->autoreply;
1214 redo CHOICE;
1215 }
1216 }
1217 }
1218
1219 CUSTOM: {
1220 print loc("
1221If there are any additional URLs you would like to use, please add them
1222now. You may enter them separately or as a space delimited list.
1223
1224We provide a default fall-back URL, but you are welcome to override it
1225with e.g. 'http://www.cpan.org/' if LWP, wget or curl is installed.
1226
1227(Enter a single space when you are done, or to simply skip this step.)
1228
1229Note that if you want to use a local depository, you will have to enter
1230as follows:
1231
1232file://server/path/to/cpan
1233
1234if the file is on a server on your local network or as:
1235
1236file:///path/to/cpan
1237
1238if the file is on your local disk. Note the three /// after the file: bit
1239
1240");
1241
1242 CHOICE: {
1243 my $reply = $term->get_reply(
1244 prompt => loc("Additionals host(s) to add: "),
1245 default => '',
1246 );
1247
1248 last CHOICE unless $reply =~ /\S/;
1249
1250 my $href = $self->_parse_host($reply);
1251
1252 if( $href ) {
1253 push @hosts, $href
1254 unless grep {
1255 $href->{'scheme'} eq $_->{'scheme'} and
1256 $href->{'host'} eq $_->{'host'} and
1257 $href->{'path'} eq $_->{'path'}
1258 } @hosts;
1259
1260 last CHOICE if $self->autoreply;
1261 } else {
1262 print loc("Invalid uri! Please try again!");
1263 }
1264
1265 $self->_view_hosts(@hosts);
1266
1267 redo CHOICE;
1268 }
1269
1270 DONE: {
1271
1272 print loc("
1273Where would you like to go now?
1274
1275Please pick one of the following options or Quit when you are done
1276
1277");
1278 my $answer = $term->get_reply(
1279 prompt => loc("Where to now?"),
1280 default => 'Quit',
1281 choices => [qw|Mirror Custom View Quit|],
1282 );
1283
1284 if( $answer eq 'View' ) {
1285 $self->_view_hosts(@hosts);
1286 redo DONE;
1287 }
1288
1289 goto MIRROR if $answer eq 'Mirror';
1290 goto CUSTOM if $answer eq 'Custom';
1291 goto QUIT if $answer eq 'Quit';
1292 }
1293 }
1294
1295 QUIT: {
1296 $conf->set_conf( hosts => \@hosts );
1297
1298 print loc("
1299Your host configuration has been saved
1300
1301");
1302 }
1303
1304 return 1;
1305}
1306
1307sub _view_hosts {
1308 my $self = shift;
1309 my @hosts = @_;
1310
1311 print "\n\n";
1312
1313 if( scalar @hosts ) {
1314 my $i = 1;
1315 for my $host (@hosts) {
1316
1317 ### show full path on file uris, otherwise, just show host
1318 my $path = join '', (
1319 $host->{'scheme'} eq 'file'
1320 ? ( ($host->{'host'} || '[localhost]'),
1321 $host->{path} )
1322 : $host->{'host'}
1323 );
1324
1325 printf "%-40s %30s\n",
1326 loc("Selected %1",$host->{'scheme'} . '://' . $path ),
1327 loc("%quant(%2,host) selected thus far.", $i);
1328 $i++;
1329 }
1330 } else {
1331 print loc("No hosts selected so far.");
1332 }
1333
1334 print "\n\n";
1335
1336 return 1;
1337}
1338
1339sub _get_mirrored_by {
1340 my $self = shift;
1341 my $cpan = $self->backend;
1342 my $conf = $self->configure_object;
1343
1344 print loc("
1345Now, we are going to fetch the mirror list for first-time configurations.
1346This may take a while...
1347
1348");
1349
1350 ### use the enew configuratoin ###
1351 $cpan->configure_object( $conf );
1352
1353 load CPANPLUS::Module::Fake;
1354 load CPANPLUS::Module::Author::Fake;
1355
1356 my $mb = CPANPLUS::Module::Fake->new(
1357 module => $conf->_get_source('hosts'),
1358 path => '',
1359 package => $conf->_get_source('hosts'),
1360 author => CPANPLUS::Module::Author::Fake->new(
1361 _id => $cpan->_id ),
1362 _id => $cpan->_id,
1363 );
1364
1365 my $file = $cpan->_fetch( fetchdir => $conf->get_conf('base'),
1366 module => $mb );
1367
1368 return $file if $file;
1369 return;
1370}
1371
1372sub _parse_mirrored_by {
1373 my $self = shift;
1374 my $file = shift;
1375
1376 -s $file or return;
1377
1378 my $fh = new FileHandle;
1379 $fh->open("$file")
1380 or (
1381 warn(loc('Could not open file "%1": %2', $file, $!)),
1382 return
1383 );
1384
1385 ### slurp the file in ###
1386 { local $/; $file = <$fh> }
1387
1388 ### remove comments ###
1389 $file =~ s/#.*$//gm;
1390
1391 $fh->close;
1392
1393 ### sample host entry ###
1394 # ftp.sun.ac.za:
1395 # frequency = "daily"
1396 # dst_ftp = "ftp://ftp.sun.ac.za/CPAN/CPAN/"
1397 # dst_location = "Stellenbosch, South Africa, Africa (-26.1992 28.0564)"
1398 # dst_organisation = "University of Stellenbosch"
1399 # dst_timezone = "+2"
1400 # dst_contact = "ftpadm@ftp.sun.ac.za"
1401 # dst_src = "ftp.funet.fi"
1402 #
1403 # # dst_dst = "ftp://ftp.sun.ac.za/CPAN/CPAN/"
1404 # # dst_contact = "mailto:ftpadm@ftp.sun.ac.za
1405 # # dst_src = "ftp.funet.fi"
1406
1407 ### host name as key, rest of the entry as value ###
1408 my %hosts = $file =~ m/([a-zA-Z0-9\-\.]+):\s+((?:\w+\s+=\s+".*?"\s+)+)/gs;
1409
1410 while (my($host,$data) = each %hosts) {
1411
1412 my $href;
1413 map {
1414 s/^\s*//;
1415 my @a = split /\s*=\s*/;
1416 $a[1] =~ s/^"(.+?)"$/$1/g;
1417 $href->{ pop @a } = pop @a;
1418 } grep /\S/, split /\n/, $data;
1419
1420 ($href->{city_area}, $href->{country}, $href->{continent},
1421 $href->{latitude}, $href->{longitude} ) =
1422 $href->{dst_location} =~
1423 m/
1424 #Aizu-Wakamatsu, Tohoku-chiho, Fukushima
1425 ^"?(
1426 (?:[^,]+?)\s* # city
1427 (?:
1428 (?:,\s*[^,]+?)\s* # optional area
1429 )*? # some have multiple areas listed
1430 )
1431
1432 #Japan
1433 ,\s*([^,]+?)\s* # country
1434
1435 #Asia
1436 ,\s*([^,]+?)\s* # continent
1437
1438 # (37.4333 139.9821)
1439 \((\S+)\s+(\S+?)\)"?$ # (latitude longitude)
1440 /sx;
1441
1442 ### parse the different hosts, store them in config format ###
1443 my @list;
1444
1445 for my $type (qw[dst_ftp dst_rsync dst_http]) {
1446 my $path = $href->{$type};
1447 next unless $path =~ /\w/;
1448 if ($type eq 'dst_rsync' && $path !~ /^rsync:/) {
1449 $path =~ s{::}{/};
1450 $path = "rsync://$path/";
1451 }
1452 my $parts = $self->_parse_host($path);
1453 push @list, $parts;
1454 }
1455
1456 $href->{connections} = \@list;
1457 $hosts{$host} = $href;
1458 }
1459
1460 return \%hosts;
1461}
1462
1463sub _parse_host {
1464 my $self = shift;
1465 my $host = shift;
1466
1467 my @parts = $host =~ m|^(\w*)://([^/]*)(/.*)$|s;
1468
1469 my $href;
1470 for my $key (qw[scheme host path]) {
1471 $href->{$key} = shift @parts;
1472 }
1473
1474 return if lc($href->{'scheme'}) ne 'file' and !$href->{'host'};
1475 return if !$href->{'path'};
1476
1477 return $href;
1478}
1479
1480## tries to figure out close hosts based on your timezone
1481##
1482## Currently can only report on unique items for each of zones, countries, and
1483## sites. In the future this will be combined with something else (perhaps a
1484## ping?) to narrow down multiple choices.
1485##
1486## Tries to return the best zone, country, and site for your location. Any non-
1487## unique items will be set to undef instead.
1488##
1489## (takes hashref, returns array)
1490##
1491sub _guess_from_timezone {
1492 my $self = shift;
1493 my $hosts = shift;
1494 my (%zones, %countries, %sites);
1495
1496 ### autrijus - build time zone table
1497 my %freq_weight = (
1498 'hourly' => 2400,
1499 '4 times a day' => 400,
1500 '4x daily' => 400,
1501 'daily' => 100,
1502 'twice daily' => 50,
1503 'weekly' => 15,
1504 );
1505
1506 while (my ($site, $host) = each %{$hosts}) {
1507 my ($zone, $continent, $country, $frequency) =
1508 @{$host}{qw/dst_timezone continent country frequency/};
1509
1510
1511 # skip non-well-formed ones
1512 next unless $continent and $country and $zone =~ /^[-+]?\d+(?::30)?/;
1513 ### fix style
1514 chomp $zone;
1515 $zone =~ s/:30/.5/;
1516 $zone =~ s/^\+//;
1517 $zone =~ s/"//g;
1518
1519 $zones{$zone}{$continent}++;
1520 $countries{$zone}{$continent}{$country}++;
1521 $sites{$zone}{$continent}{$country}{$site} = $freq_weight{$frequency};
1522 }
1523
1524 use Time::Local;
1525 my $offset = ((timegm(localtime) - timegm(gmtime)) / 3600);
1526
1527 local $_;
1528
1529 ## pick the entry with most country/site/frequency, one level each;
1530 ## note it has to be sorted -- otherwise we're depending on the hash order.
1531 ## also, the list context assignment (pick first one) is deliberate.
1532
1533 my ($continent) = map {
1534 (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
1535 } $zones{$offset};
1536
1537 my ($country) = map {
1538 (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
1539 } $countries{$offset}{$continent};
1540
1541 my ($site) = map {
1542 (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
1543 } $sites{$offset}{$continent}{$country};
1544
1545 return ($continent, $country, $site);
1546} # _guess_from_timezone
1547
1548
1549### big big regex, stolen to check if you enter a valid address
1550{
1551 my $RFC822PAT; # RFC pattern to match for valid email address
1552
1553 sub _valid_email {
1554 my $self = shift;
1555 if (!$RFC822PAT) {
1556 my $esc = '\\\\'; my $Period = '\.'; my $space = '\040';
1557 my $tab = '\t'; my $OpenBR = '\['; my $CloseBR = '\]';
1558 my $OpenParen = '\('; my $CloseParen = '\)'; my $NonASCII = '\x80-\xff';
1559 my $ctrl = '\000-\037'; my $CRlist = '\012\015';
1560
1561 my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
1562 my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
1563 my $quoted_pair = qq< $esc [^$NonASCII] >; # an escaped character
1564 my $ctext = qq< [^$esc$NonASCII$CRlist()] >;
1565 my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >;
1566 my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >;
1567 my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >;
1568 my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
1569 my $atom = qq< $atom_char+ (?!$atom_char) >;
1570 my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >;
1571 my $word = qq< (?: $atom | $quoted_str ) >;
1572 my $domain_ref = $atom;
1573 my $domain_lit = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >;
1574 my $sub_domain = qq< (?: $domain_ref | $domain_lit) $X >;
1575 my $domain = qq< $sub_domain (?: $Period $X $sub_domain)* >;
1576 my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;
1577 my $local_part = qq< $word $X (?: $Period $X $word $X )* >;
1578 my $addr_spec = qq< $local_part \@ $X $domain >;
1579 my $route_addr = qq[ < $X (?: $route )? $addr_spec > ];
1580 my $phrase_ctrl = '\000-\010\012-\037'; # like ctrl, but without tab
1581 my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
1582 my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >;
1583 $RFC822PAT = qq< $X (?: $addr_spec | $phrase $route_addr) >;
1584 }
1585
1586 return scalar ($_[0] =~ /$RFC822PAT/ox);
1587 }
1588}
1589
1590
1591
1592
1593
1594
15951;
1596
1597
1598sub _edit {
1599 my $self = shift;
1600 my $conf = $self->configure_object;
1601 my $file = shift || $conf->_config_pm_to_file( $self->config_type );
1602 my $editor = shift || $conf->get_program('editor');
1603 my $term = $self->term;
1604
1605 unless( $editor ) {
1606 print loc("
1607I'm sorry, I can't find a suitable editor, so I can't offer you
1608post-configuration editing of the config file
1609
1610");
1611 return 1;
1612 }
1613
1614 ### save the thing first, so there's something to edit
1615 $self->_save;
1616
1617 return !system("$editor $file");
1618}
1619
1620sub _save {
1621 my $self = shift;
1622 my $conf = $self->configure_object;
1623
1624 return $conf->save( $self->config_type );
1625}
1626
16271;