projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Fix random failures in CPANPLUS tests on Win32
[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'.
478
479 ", 'c:\Progra~1\prog.exe' );
480
481 for my $prog ( sort $conf->options( type => 'program') ) {
482 PROGRAM: {
483 print loc("Where can I find your '%1' utility? ".
484 "(Enter a single space to disable)", $prog );
485
486 my $loc = $term->get_reply(
487 prompt => "Path to your '$prog'",
488 default => $conf->get_program( $prog ),
489 );
490
491 ### empty line clears it
492 my $cmd = $loc =~ /^\s*$/ ? undef : $loc;
493 my ($bin) = $cmd =~ /^(\S+)/;
494
495 ### did you provide a valid program ?
496 if( $bin and not can_run( $bin ) ) {
497 print "\n";
498 print loc("Can not find the binary '%1' in your path!", $bin);
499 redo PROGRAM;
500 }
501
502 ### make is special -- we /need/ it!
503 if( $prog eq 'make' and not $bin ) {
504 print loc(
505 "==> Without your '%1' utility, I can not function! <==",
506 'make'
507 );
508 print loc("Please provide one!");
509
510 ### show win32 where to download
511 if ( $^O eq 'MSWin32' ) {
512 print loc("You can get '%1' from:", NMAKE);
513 print "\t". NMAKE_URL ."\n";
514 }
515 print "\n";
516 redo PROGRAM;
517 }
518
519 $conf->set_program( $prog => $cmd );
520 print $cmd
521 ? loc( "Your '%1' utility has been set to '%2'",
522 $prog, $cmd )
523 : loc( "Your '%1' has been disabled", $prog );
524 print "\n";
525 }
526 }
527
528 return 1;
529}
530
531sub _setup_installer {
532 my $self = shift;
533 my $term = $self->term;
534 my $conf = $self->configure_object;
535
536 my $none = 'None';
537 {
538 print loc("
539CPANPLUS uses binary programs as well as Perl modules to accomplish
540various tasks. Normally, CPANPLUS will prefer the use of Perl modules
541over binary programs.
542
543You can change this setting by making CPANPLUS prefer the use of
544certain binary programs if they are available.
545
546 ");
547
548 ### default to using binaries if we don't have compress::zlib only
549 ### -- it'll get very noisy otherwise
550 my $type = 'prefer_bin';
551 my $yn = $term->ask_yn(
552 prompt => loc("Should I prefer the use of binary programs?"),
553 default => $conf->get_conf( $type ),
554 );
555
556 print $yn
557 ? loc("Ok, I will prefer to use binary programs if possible.")
558 : loc("Ok, I will prefer to use Perl modules if possible.");
559 print "\n\n";
560
561
562 $conf->set_conf( $type => $yn );
563 }
564
565 {
566 print loc("
567Makefile.PL is run by perl in a separate process, and accepts various
568flags that controls the module's installation. For instance, if you
569would like to install modules to your private user directory, set
570'makemakerflags' to:
571
572LIB=~/perl/lib INSTALLMAN1DIR=~/perl/man/man1 INSTALLMAN3DIR=~/perl/man/man3
573
574and be sure that you do NOT set UNINST=1 in 'makeflags' below.
575
576Enter a name=value list separated by whitespace, but quote any embedded
577spaces that you want to preserve. (Enter a space to clear any existing
578settings.)
579
580If you don't understand this question, just press ENTER.
581
582 ");
583
584 my $type = 'makemakerflags';
585 my $flags = $term->get_reply(
586 prompt => 'Makefile.PL flags?',
587 default => $conf->get_conf($type),
588 );
589
590 $flags = '' if $flags eq $none || $flags !~ /\S/;
591
592 print "\n", loc("Your '%1' have been set to:", 'Makefile.PL flags'),
593 "\n ", ( $flags ? $flags : loc('*nothing entered*')),
594 "\n\n";
595
596 $conf->set_conf( $type => $flags );
597 }
598
599 {
600 print loc("
601Like Makefile.PL, we run 'make' and 'make install' as separate processes.
602If you have any parameters (e.g. '-j3' in dual processor systems) you want
603to pass to the calls, please specify them here.
604
605In particular, 'UNINST=1' is recommended for root users, unless you have
606fine-tuned ideas of where modules should be installed in the \@INC path.
607
608Enter a name=value list separated by whitespace, but quote any embedded
609spaces that you want to preserve. (Enter a space to clear any existing
610settings.)
611
612Again, if you don't understand this question, just press ENTER.
613
614 ");
615 my $type = 'makeflags';
616 my $flags = $term->get_reply(
617 prompt => 'make flags?',
618 default => $conf->get_conf($type),
619 );
620
621 $flags = '' if $flags eq $none || $flags !~ /\S/;
622
623 print "\n", loc("Your '%1' have been set to:", $type),
624 "\n ", ( $flags ? $flags : loc('*nothing entered*')),
625 "\n\n";
626
627 $conf->set_conf( $type => $flags );
628 }
629
630 {
631 print loc("
632An alternative to ExtUtils::MakeMaker and Makefile.PL there's a module
633called Module::Build which uses a Build.PL.
634
635If you would like to specify any flags to pass when executing the
636Build.PL (and Build) script, please enter them below.
637
638For instance, if you would like to install modules to your private
639user directory, you could enter:
640
641 install_base=/my/private/path
642
643Or to uninstall old copies of modules before updating, you might
644want to enter:
645
646 uninst=1
647
648Again, if you don't understand this question, just press ENTER.
649
650 ");
651
652 my $type = 'buildflags';
653 my $flags = $term->get_reply(
654 prompt => 'Build.PL and Build flags?',
655 default => $conf->get_conf($type),
656 );
657
658 $flags = '' if $flags eq $none || $flags !~ /\S/;
659
660 print "\n", loc("Your '%1' have been set to:",
661 'Build.PL and Build flags'),
662 "\n ", ( $flags ? $flags : loc('*nothing entered*')),
663 "\n\n";
664
665 $conf->set_conf( $type => $flags );
666 }
667
668 ### use EU::MM or module::build? ###
669 {
670 print loc("
671Some modules provide both a Build.PL (Module::Build) and a Makefile.PL
672(ExtUtils::MakeMaker). By default, CPANPLUS prefers Makefile.PL.
673
674Module::Build support is not bundled standard with CPANPLUS, but
675requires you to install 'CPANPLUS::Dist::Build' from CPAN.
676
677Although Module::Build is a pure perl solution, which means you will
678not need a 'make' binary, it does have some limitations. The most
679important is that CPANPLUS is unable to uninstall any modules installed
680by Module::Build.
681
682Again, if you don't understand this question, just press ENTER.
683
684 ");
685 my $type = 'prefer_makefile';
686 my $yn = $term->ask_yn(
687 prompt => loc("Prefer Makefile.PL over Build.PL?"),
688 default => $conf->get_conf($type),
689 );
690
691 $conf->set_conf( $type => $yn );
692 }
693
694 {
695 print loc('
696If you like, CPANPLUS can add extra directories to your @INC list during
697startup. These will just be used by CPANPLUS and will not change your
698external environment or perl interpreter. Enter a space separated list of
699pathnames to be added to your @INC, quoting any with embedded whitespace.
700(To clear the current value enter a single space.)
701
702 ');
703
704 my $type = 'lib';
705 my $flags = $term->get_reply(
706 prompt => loc('Additional @INC directories to add?'),
707 default => (join " ", @{$conf->get_conf($type) || []} ),
708 );
709
710 my $lib;
711 unless( $flags =~ /\S/ ) {
712 $lib = [];
713 } else {
714 (@$lib) = $flags =~ m/\s*("[^"]+"|'[^']+'|[^\s]+)/g;
715 }
716
717 print "\n", loc("Your additional libs are now:"), "\n";
718
719 print scalar @$lib
720 ? map { " $_\n" } @$lib
721 : " ", loc("*nothing entered*"), "\n";
722 print "\n\n";
723
724 $conf->set_conf( $type => $lib );
725 }
726
727 return 1;
728}
729
730
731sub _setup_conf {
732 my $self = shift;
733 my $term = $self->term;
734 my $conf = $self->configure_object;
735
736 my $none = 'None';
737 {
738 ############
739 ## noisy? ##
740 ############
741
742 print loc("
743In normal operation I can just give you basic information about what I
744am doing, or I can be more verbose and give you every little detail.
745
746 ");
747
748 my $type = 'verbose';
749 my $yn = $term->ask_yn(
750 prompt => loc("Should I be verbose?"),
751 default => $conf->get_conf( $type ), );
752
753 print "\n";
754 print $yn
755 ? loc("You asked for it!")
756 : loc("I'll try to be quiet");
757
758 $conf->set_conf( $type => $yn );
759 }
760
761 {
762 #######################
763 ## flush you animal! ##
764 #######################
765
766 print loc("
767In the interest of speed, we keep track of what modules were installed
768successfully and which failed in the current session. We can flush this
769data automatically, or you can explicitly issue a 'flush' when you want
770to purge it.
771
772 ");
773
774 my $type = 'flush';
775 my $yn = $term->ask_yn(
776 prompt => loc("Flush automatically?"),
777 default => $conf->get_conf( $type ),
778 );
779
780 print "\n";
781 print $yn
782 ? loc("I'll flush after every full module install.")
783 : loc("I won't flush until you tell me to.");
784
785 $conf->set_conf( $type => $yn );
786 }
787
788 {
789 #####################
790 ## force installs? ##
791 #####################
792
793 print loc("
794Usually, when a test fails, I won't install the module, but if you
795prefer, I can force the install anyway.
796
797 ");
798
799 my $type = 'force';
800 my $yn = $term->ask_yn(
801 prompt => loc("Force installs?"),
802 default => $conf->get_conf( $type ),
803 );
804
805 print "\n";
806 print $yn
807 ? loc("I will force installs.")
808 : loc("I won't force installs.");
809
810 $conf->set_conf( $type => $yn );
811 }
812
813 {
814 ###################
815 ## about prereqs ##
816 ###################
817
818 print loc("
819Sometimes a module will require other modules to be installed before it
820will work. CPANPLUS can attempt to install these for you automatically
821if you like, or you can do the deed yourself.
822
823If you would prefer that we NEVER try to install extra modules
824automatically, select NO. (Usually you will want this set to YES.)
825
826If you would like to build modules to satisfy testing or prerequisites,
827but not actually install them, select BUILD.
828
829NOTE: This feature requires you to flush the 'lib' cache for longer
830running programs (refer to the CPANPLUS::Backend documentations for
831more details).
832
833Otherwise, select ASK to have us ask your permission to install them.
834
835 ");
836
837 my $type = 'prereqs';
838
839 my @map = (
840 [ PREREQ_IGNORE, # conf value
841 loc('No, do not install prerequisites'), # UI Value
842 loc("I won't install prerequisites") # diag message
843 ],
844 [ PREREQ_INSTALL,
845 loc('Yes, please install prerequisites'),
846 loc("I will install prerequisites")
847 ],
848 [ PREREQ_ASK,
849 loc('Ask me before installing a prerequisite'),
850 loc("I will ask permission to install")
851 ],
852 [ PREREQ_BUILD,
853 loc('Build prerequisites, but do not install them'),
854 loc( "I will only build, but not install prerequisites" )
855 ],
856 );
857
858 my %reply = map { $_->[1] => $_->[0] } @map; # choice => value
859 my %diag = map { $_->[1] => $_->[2] } @map; # choice => diag message
860 my %conf = map { $_->[0] => $_->[1] } @map; # value => ui choice
861
862 my $reply = $term->get_reply(
863 prompt => loc('Follow prerequisites?'),
864 default => $conf{ $conf->get_conf( $type ) },
865 choices => [ @conf{ sort keys %conf } ],
866 );
867 print "\n";
868
869 my $value = $reply{ $reply };
870 my $diag = $diag{ $reply };
871
872 $conf->set_conf( $type => $value );
873 print $diag, "\n";
874 }
875
876 { print loc("
877Modules in the CPAN archives are protected with md5 checksums.
878
879This requires the Perl module Digest::MD5 to be installed (which
880CPANPLUS can do for you later);
881
882 ");
883 my $type = 'md5';
884
885 my $yn = $term->ask_yn(
886 prompt => loc("Shall I use the MD5 checksums?"),
887 default => $conf->get_conf( $type ),
888 );
889
890 print $yn
891 ? loc("I will use the MD5 checksums if you have it")
892 : loc("I won't use the MD5 checksums");
893
894 $conf->set_conf( $type => $yn );
895
896 }
897
898
899 { ###########################################
900 ## sally sells seashells by the seashore ##
901 ###########################################
902
903 print loc("
904By default CPANPLUS uses its own shell when invoked. If you would prefer
905a different shell, such as one you have written or otherwise acquired,
906please enter the full name for your shell module.
907
908 ");
909
910 my $type = 'shell';
911 my $other = 'Other';
912 my @choices = (qw| CPANPLUS::Shell::Default
913 CPANPLUS::Shell::Classic |,
914 $other );
915 my $default = $conf->get_conf($type);
916
917 unshift @choices, $default unless grep { $_ eq $default } @choices;
918
919 my $reply = $term->get_reply(
920 prompt => loc('Which CPANPLUS shell do you want to use?'),
921 default => $default,
922 choices => \@choices,
923 );
924
925 if( $reply eq $other ) {
926 SHELL: {
927 $reply = $term->get_reply(
928 prompt => loc( 'Please enter the name of the shell '.
929 'you wish to use: '),
930 );
931
932 unless( check_install( module => $reply ) ) {
933 print "\n",
934 loc("Could not find '$reply' in your path " .
935 "-- please try again"),
936 "\n";
937 redo SHELL;
938 }
939 }
940 }
941
942 print "\n", loc("Your shell is now: %1", $reply), "\n\n";
943
944 $conf->set_conf( $type => $reply );
945 }
946
947 {
948 ###################
949 ## use storable? ##
950 ###################
951
952 print loc("
953To speed up the start time of CPANPLUS, and maintain a cache over
954multiple runs, we can use Storable to freeze some information.
955Would you like to do this?
956
957");
958 my $type = 'storable';
959 my $yn = $term->ask_yn(
960 prompt => loc("Use Storable?"),
961 default => $conf->get_conf( $type ) ? 1 : 0,
962 );
963 print "\n";
964 print $yn
965 ? loc("I will use Storable if you have it")
966 : loc("I will not use Storable");
967
968 $conf->set_conf( $type => $yn );
969 }
970
971 {
972 ###################
973 ## use cpantest? ##
974 ###################
975
976 print loc("
977CPANPLUS has support for the Test::Reporter module, which can be utilized
978to report success and failures of modules installed by CPANPLUS. Would
979you like to do this? Note that you will still be prompted before
980sending each report.
981
982If you don't have all the required modules installed yet, you should
983consider installing '%1'
984
985This package bundles all the required modules to enable test reporting
986and querying from CPANPLUS.
987You can do so straight after this installation.
988
989 ", 'Bundle::CPANPLUS::Test::Reporter');
990
991 my $type = 'cpantest';
992 my $yn = $term->ask_yn(
993 prompt => loc('Report test results?'),
994 default => $conf->get_conf( $type ) ? 1 : 0,
995 );
996
997 print "\n";
998 print $yn
999 ? loc("I will prompt you to report test results")
1000 : loc("I won't prompt you to report test results");
1001
1002 $conf->set_conf( $type => $yn );
1003 }
1004
1005 {
1006 ###################################
1007 ## use cryptographic signatures? ##
1008 ###################################
1009
1010 print loc("
1011The Module::Signature extension allows CPAN authors to sign their
1012distributions using PGP signatures. Would you like to check for
1013module's cryptographic integrity before attempting to install them?
1014Note that this requires either the 'gpg' utility or Crypt::OpenPGP
1015to be installed.
1016
1017 ");
1018 my $type = 'signature';
1019
1020 my $yn = $term->ask_yn(
1021 prompt => loc('Shall I check module signatures?'),
1022 default => $conf->get_conf($type) ? 1 : 0,
1023 );
1024
1025 print "\n";
1026 print $yn
1027 ? loc("Ok, I will attempt to check module signatures.")
1028 : loc("Ok, I won't attempt to check module signatures.");
1029
1030 $conf->set_conf( $type => $yn );
1031 }
1032
1033 return 1;
1034}
1035
1036sub _setup_hosts {
1037 my $self = shift;
1038 my $term = $self->term;
1039 my $conf = $self->configure_object;
1040
1041
1042 if( scalar @{ $conf->get_conf('hosts') } ) {
1043
1044 my $hosts;
1045 for my $href ( @{$conf->get_conf('hosts')} ) {
1046 $hosts .= "\t$href->{scheme}://$href->{host}$href->{path}\n";
1047 }
1048
1049 print loc("
1050I see you already have some hosts selected:
1051
1052$hosts
1053
1054If you'd like to stick with your current settings, just select 'Yes'.
1055Otherwise, select 'No' and you can reconfigure your hosts
1056
1057");
1058 my $yn = $term->ask_yn(
1059 prompt => loc("Would you like to keep your current hosts?"),
1060 default => 'y',
1061 );
1062 return 1 if $yn;
1063 }
1064
1065 my @hosts;
1066 MAIN: {
1067
1068 print loc("
1069Now we need to know where your favorite CPAN sites are located. Make a
1070list of a few sites (just in case the first on the array won't work).
1071
1072If you are mirroring CPAN to your local workstation, specify a file:
1073URI by picking the CUSTOM option.
1074
1075Otherwise, let us fetch the official CPAN mirror list and you can pick
1076the mirror that suits you best from a list by using the MIRROR option;
1077First, pick a nearby continent and country. Then, you will be presented
1078with a list of URLs of CPAN mirrors in the country you selected. Select
1079one or more of those URLs.
1080
1081Note, the latter option requires a working net connection.
1082
1083You can select VIEW to see your current selection and QUIT when you
1084are done.
1085
1086");
1087
1088 my $reply = $term->get_reply(
1089 prompt => loc('Please choose an option'),
1090 choices => [qw|Mirror Custom View Quit|],
1091 default => 'Mirror',
1092 );
1093
1094 goto MIRROR if $reply eq 'Mirror';
1095 goto CUSTOM if $reply eq 'Custom';
1096 goto QUIT if $reply eq 'Quit';
1097
1098 $self->_view_hosts(@hosts) if $reply eq 'View';
1099 redo MAIN;
1100 }
1101
1102 my $mirror_file;
1103 my $hosts;
1104 MIRROR: {
1105 $mirror_file ||= $self->_get_mirrored_by or return;
1106 $hosts ||= $self->_parse_mirrored_by($mirror_file) or return;
1107
1108 my ($continent, $country, $host) = $self->_guess_from_timezone( $hosts );
1109
1110 CONTINENT: {
1111 my %seen;
1112 my @choices = sort map {
1113 $_->{'continent'}
1114 } grep {
1115 not $seen{$_->{'continent'}}++
1116 } values %$hosts;
1117 push @choices, qw[Custom Up Quit];
1118
1119 my $reply = $term->get_reply(
1120 prompt => loc('Pick a continent'),
1121 default => $continent,
1122 choices => \@choices,
1123 );
1124
1125 goto MAIN if $reply eq 'Up';
1126 goto CUSTOM if $reply eq 'Custom';
1127 goto QUIT if $reply eq 'Quit';
1128
1129 $continent = $reply;
1130 }
1131
1132 COUNTRY: {
1133 my %seen;
1134 my @choices = sort map {
1135 $_->{'country'}
1136 } grep {
1137 not $seen{$_->{'country'}}++
1138 } grep {
1139 ($_->{'continent'} eq $continent)
1140 } values %$hosts;
1141 push @choices, qw[Custom Up Quit];
1142
1143 my $reply = $term->get_reply(
1144 prompt => loc('Pick a country'),
1145 default => $country,
1146 choices => \@choices,
1147 );
1148
1149 goto CONTINENT if $reply eq 'Up';
1150 goto CUSTOM if $reply eq 'Custom';
1151 goto QUIT if $reply eq 'Quit';
1152
1153 $country = $reply;
1154 }
1155
1156 HOST: {
1157 my @list = grep {
1158 $_->{'continent'} eq $continent and
1159 $_->{'country'} eq $country
1160 } values %$hosts;
1161
1162 my %map; my $default;
1163 for my $href (@list) {
1164 for my $con ( @{$href->{'connections'}} ) {
1165 next unless length $con->{'host'};
1166
1167 my $entry = $con->{'scheme'} . '://' . $con->{'host'};
1168 $default = $entry if $con->{'host'} eq $host;
1169
1170 $map{$entry} = $con;
1171 }
1172 }
1173
1174 CHOICE: {
1175
1176 ### doesn't play nice with Term::UI :(
1177 ### should make t::ui figure out pager opens
1178 #$self->_pager_open; # host lists might be long
1179
1180 print loc("
1181You can enter multiple sites by seperating them by a space.
1182For example:
1183 1 4 2 5
1184 ");
1185
1186 my @reply = $term->get_reply(
1187 prompt => loc('Please pick a site: '),
1188 choices => [sort(keys %map),
1189 qw|Custom View Up Quit|],
1190 default => $default,
1191 multi => 1,
1192 );
1193 #$self->_pager_close;
1194
1195
1196 goto COUNTRY if grep { $_ eq 'Up' } @reply;
1197 goto CUSTOM if grep { $_ eq 'Custom' } @reply;
1198 goto QUIT if grep { $_ eq 'Quit' } @reply;
1199
1200 ### add the host, but only if it's not on the stack already ###
1201 unless( grep { $_ eq 'View' } @reply ) {
1202 for my $reply (@reply) {
1203 if( grep { $_ eq $map{$reply} } @hosts ) {
1204 print loc("Host '%1' already selected", $reply);
1205 print "\n\n";
1206 } else {
1207 push @hosts, $map{$reply}
1208 }
1209 }
1210 }
1211
1212 $self->_view_hosts(@hosts);
1213
1214 goto QUIT if $self->autoreply;
1215 redo CHOICE;
1216 }
1217 }
1218 }
1219
1220 CUSTOM: {
1221 print loc("
1222If there are any additional URLs you would like to use, please add them
1223now. You may enter them separately or as a space delimited list.
1224
1225We provide a default fall-back URL, but you are welcome to override it
1226with e.g. 'http://www.cpan.org/' if LWP, wget or curl is installed.
1227
1228(Enter a single space when you are done, or to simply skip this step.)
1229
1230Note that if you want to use a local depository, you will have to enter
1231as follows:
1232
1233file://server/path/to/cpan
1234
1235if the file is on a server on your local network or as:
1236
1237file:///path/to/cpan
1238
1239if the file is on your local disk. Note the three /// after the file: bit
1240
1241");
1242
1243 CHOICE: {
1244 my $reply = $term->get_reply(
1245 prompt => loc("Additionals host(s) to add: "),
1246 default => '',
1247 );
1248
1249 last CHOICE unless $reply =~ /\S/;
1250
1251 my $href = $self->_parse_host($reply);
1252
1253 if( $href ) {
1254 push @hosts, $href
1255 unless grep {
1256 $href->{'scheme'} eq $_->{'scheme'} and
1257 $href->{'host'} eq $_->{'host'} and
1258 $href->{'path'} eq $_->{'path'}
1259 } @hosts;
1260
1261 last CHOICE if $self->autoreply;
1262 } else {
1263 print loc("Invalid uri! Please try again!");
1264 }
1265
1266 $self->_view_hosts(@hosts);
1267
1268 redo CHOICE;
1269 }
1270
1271 DONE: {
1272
1273 print loc("
1274Where would you like to go now?
1275
1276Please pick one of the following options or Quit when you are done
1277
1278");
1279 my $answer = $term->get_reply(
1280 prompt => loc("Where to now?"),
1281 default => 'Quit',
1282 choices => [qw|Mirror Custom View Quit|],
1283 );
1284
1285 if( $answer eq 'View' ) {
1286 $self->_view_hosts(@hosts);
1287 redo DONE;
1288 }
1289
1290 goto MIRROR if $answer eq 'Mirror';
1291 goto CUSTOM if $answer eq 'Custom';
1292 goto QUIT if $answer eq 'Quit';
1293 }
1294 }
1295
1296 QUIT: {
1297 $conf->set_conf( hosts => \@hosts );
1298
1299 print loc("
1300Your host configuration has been saved
1301
1302");
1303 }
1304
1305 return 1;
1306}
1307
1308sub _view_hosts {
1309 my $self = shift;
1310 my @hosts = @_;
1311
1312 print "\n\n";
1313
1314 if( scalar @hosts ) {
1315 my $i = 1;
1316 for my $host (@hosts) {
1317
1318 ### show full path on file uris, otherwise, just show host
1319 my $path = join '', (
1320 $host->{'scheme'} eq 'file'
1321 ? ( ($host->{'host'} || '[localhost]'),
1322 $host->{path} )
1323 : $host->{'host'}
1324 );
1325
1326 printf "%-40s %30s\n",
1327 loc("Selected %1",$host->{'scheme'} . '://' . $path ),
1328 loc("%quant(%2,host) selected thus far.", $i);
1329 $i++;
1330 }
1331 } else {
1332 print loc("No hosts selected so far.");
1333 }
1334
1335 print "\n\n";
1336
1337 return 1;
1338}
1339
1340sub _get_mirrored_by {
1341 my $self = shift;
1342 my $cpan = $self->backend;
1343 my $conf = $self->configure_object;
1344
1345 print loc("
1346Now, we are going to fetch the mirror list for first-time configurations.
1347This may take a while...
1348
1349");
1350
1351 ### use the enew configuratoin ###
1352 $cpan->configure_object( $conf );
1353
1354 load CPANPLUS::Module::Fake;
1355 load CPANPLUS::Module::Author::Fake;
1356
1357 my $mb = CPANPLUS::Module::Fake->new(
1358 module => $conf->_get_source('hosts'),
1359 path => '',
1360 package => $conf->_get_source('hosts'),
1361 author => CPANPLUS::Module::Author::Fake->new(
1362 _id => $cpan->_id ),
1363 _id => $cpan->_id,
1364 );
1365
1366 my $file = $cpan->_fetch( fetchdir => $conf->get_conf('base'),
1367 module => $mb );
1368
1369 return $file if $file;
1370 return;
1371}
1372
1373sub _parse_mirrored_by {
1374 my $self = shift;
1375 my $file = shift;
1376
1377 -s $file or return;
1378
1379 my $fh = new FileHandle;
1380 $fh->open("$file")
1381 or (
1382 warn(loc('Could not open file "%1": %2', $file, $!)),
1383 return
1384 );
1385
1386 ### slurp the file in ###
1387 { local $/; $file = <$fh> }
1388
1389 ### remove comments ###
1390 $file =~ s/#.*$//gm;
1391
1392 $fh->close;
1393
1394 ### sample host entry ###
1395 # ftp.sun.ac.za:
1396 # frequency = "daily"
1397 # dst_ftp = "ftp://ftp.sun.ac.za/CPAN/CPAN/"
1398 # dst_location = "Stellenbosch, South Africa, Africa (-26.1992 28.0564)"
1399 # dst_organisation = "University of Stellenbosch"
1400 # dst_timezone = "+2"
1401 # dst_contact = "ftpadm@ftp.sun.ac.za"
1402 # dst_src = "ftp.funet.fi"
1403 #
1404 # # dst_dst = "ftp://ftp.sun.ac.za/CPAN/CPAN/"
1405 # # dst_contact = "mailto:ftpadm@ftp.sun.ac.za
1406 # # dst_src = "ftp.funet.fi"
1407
1408 ### host name as key, rest of the entry as value ###
1409 my %hosts = $file =~ m/([a-zA-Z0-9\-\.]+):\s+((?:\w+\s+=\s+".*?"\s+)+)/gs;
1410
1411 while (my($host,$data) = each %hosts) {
1412
1413 my $href;
1414 map {
1415 s/^\s*//;
1416 my @a = split /\s*=\s*/;
1417 $a[1] =~ s/^"(.+?)"$/$1/g;
1418 $href->{ pop @a } = pop @a;
1419 } grep /\S/, split /\n/, $data;
1420
1421 ($href->{city_area}, $href->{country}, $href->{continent},
1422 $href->{latitude}, $href->{longitude} ) =
1423 $href->{dst_location} =~
1424 m/
1425 #Aizu-Wakamatsu, Tohoku-chiho, Fukushima
1426 ^"?(
1427 (?:[^,]+?)\s* # city
1428 (?:
1429 (?:,\s*[^,]+?)\s* # optional area
1430 )*? # some have multiple areas listed
1431 )
1432
1433 #Japan
1434 ,\s*([^,]+?)\s* # country
1435
1436 #Asia
1437 ,\s*([^,]+?)\s* # continent
1438
1439 # (37.4333 139.9821)
1440 \((\S+)\s+(\S+?)\)"?$ # (latitude longitude)
1441 /sx;
1442
1443 ### parse the different hosts, store them in config format ###
1444 my @list;
1445
1446 for my $type (qw[dst_ftp dst_rsync dst_http]) {
1447 my $path = $href->{$type};
1448 next unless $path =~ /\w/;
1449 if ($type eq 'dst_rsync' && $path !~ /^rsync:/) {
1450 $path =~ s{::}{/};
1451 $path = "rsync://$path/";
1452 }
1453 my $parts = $self->_parse_host($path);
1454 push @list, $parts;
1455 }
1456
1457 $href->{connections} = \@list;
1458 $hosts{$host} = $href;
1459 }
1460
1461 return \%hosts;
1462}
1463
1464sub _parse_host {
1465 my $self = shift;
1466 my $host = shift;
1467
1468 my @parts = $host =~ m|^(\w*)://([^/]*)(/.*)$|s;
1469
1470 my $href;
1471 for my $key (qw[scheme host path]) {
1472 $href->{$key} = shift @parts;
1473 }
1474
1475 return if lc($href->{'scheme'}) ne 'file' and !$href->{'host'};
1476 return if !$href->{'path'};
1477
1478 return $href;
1479}
1480
1481## tries to figure out close hosts based on your timezone
1482##
1483## Currently can only report on unique items for each of zones, countries, and
1484## sites. In the future this will be combined with something else (perhaps a
1485## ping?) to narrow down multiple choices.
1486##
1487## Tries to return the best zone, country, and site for your location. Any non-
1488## unique items will be set to undef instead.
1489##
1490## (takes hashref, returns array)
1491##
1492sub _guess_from_timezone {
1493 my $self = shift;
1494 my $hosts = shift;
1495 my (%zones, %countries, %sites);
1496
1497 ### autrijus - build time zone table
1498 my %freq_weight = (
1499 'hourly' => 2400,
1500 '4 times a day' => 400,
1501 '4x daily' => 400,
1502 'daily' => 100,
1503 'twice daily' => 50,
1504 'weekly' => 15,
1505 );
1506
1507 while (my ($site, $host) = each %{$hosts}) {
1508 my ($zone, $continent, $country, $frequency) =
1509 @{$host}{qw/dst_timezone continent country frequency/};
1510
1511
1512 # skip non-well-formed ones
1513 next unless $continent and $country and $zone =~ /^[-+]?\d+(?::30)?/;
1514 ### fix style
1515 chomp $zone;
1516 $zone =~ s/:30/.5/;
1517 $zone =~ s/^\+//;
1518 $zone =~ s/"//g;
1519
1520 $zones{$zone}{$continent}++;
1521 $countries{$zone}{$continent}{$country}++;
1522 $sites{$zone}{$continent}{$country}{$site} = $freq_weight{$frequency};
1523 }
1524
1525 use Time::Local;
1526 my $offset = ((timegm(localtime) - timegm(gmtime)) / 3600);
1527
1528 local $_;
1529
1530 ## pick the entry with most country/site/frequency, one level each;
1531 ## note it has to be sorted -- otherwise we're depending on the hash order.
1532 ## also, the list context assignment (pick first one) is deliberate.
1533
1534 my ($continent) = map {
1535 (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
1536 } $zones{$offset};
1537
1538 my ($country) = map {
1539 (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
1540 } $countries{$offset}{$continent};
1541
1542 my ($site) = map {
1543 (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
1544 } $sites{$offset}{$continent}{$country};
1545
1546 return ($continent, $country, $site);
1547} # _guess_from_timezone
1548
1549
1550### big big regex, stolen to check if you enter a valid address
1551{
1552 my $RFC822PAT; # RFC pattern to match for valid email address
1553
1554 sub _valid_email {
1555 my $self = shift;
1556 if (!$RFC822PAT) {
1557 my $esc = '\\\\'; my $Period = '\.'; my $space = '\040';
1558 my $tab = '\t'; my $OpenBR = '\['; my $CloseBR = '\]';
1559 my $OpenParen = '\('; my $CloseParen = '\)'; my $NonASCII = '\x80-\xff';
1560 my $ctrl = '\000-\037'; my $CRlist = '\012\015';
1561
1562 my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
1563 my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
1564 my $quoted_pair = qq< $esc [^$NonASCII] >; # an escaped character
1565 my $ctext = qq< [^$esc$NonASCII$CRlist()] >;
1566 my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >;
1567 my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >;
1568 my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >;
1569 my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
1570 my $atom = qq< $atom_char+ (?!$atom_char) >;
1571 my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >;
1572 my $word = qq< (?: $atom | $quoted_str ) >;
1573 my $domain_ref = $atom;
1574 my $domain_lit = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >;
1575 my $sub_domain = qq< (?: $domain_ref | $domain_lit) $X >;
1576 my $domain = qq< $sub_domain (?: $Period $X $sub_domain)* >;
1577 my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;
1578 my $local_part = qq< $word $X (?: $Period $X $word $X )* >;
1579 my $addr_spec = qq< $local_part \@ $X $domain >;
1580 my $route_addr = qq[ < $X (?: $route )? $addr_spec > ];
1581 my $phrase_ctrl = '\000-\010\012-\037'; # like ctrl, but without tab
1582 my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
1583 my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >;
1584 $RFC822PAT = qq< $X (?: $addr_spec | $phrase $route_addr) >;
1585 }
1586
1587 return scalar ($_[0] =~ /$RFC822PAT/ox);
1588 }
1589}
1590
1591
1592
1593
1594
1595
15961;
1597
1598
1599sub _edit {
1600 my $self = shift;
1601 my $conf = $self->configure_object;
1602 my $file = shift || $conf->_config_pm_to_file( $self->config_type );
1603 my $editor = shift || $conf->get_program('editor');
1604 my $term = $self->term;
1605
1606 unless( $editor ) {
1607 print loc("
1608I'm sorry, I can't find a suitable editor, so I can't offer you
1609post-configuration editing of the config file
1610
1611");
1612 return 1;
1613 }
1614
1615 ### save the thing first, so there's something to edit
1616 $self->_save;
1617
1618 return !system("$editor $file");
1619}
1620
1621sub _save {
1622 my $self = shift;
1623 my $conf = $self->configure_object;
1624
1625 return $conf->save( $self->config_type );
1626}
1627
16281;
Unnamed repository; edit this file to name it for gitweb.