Commit | Line | Data |
6aaee015 |
1 | package CPANPLUS::Configure::Setup; |
2 | |
3 | use strict; |
4 | use vars qw(@ISA); |
5 | |
6 | use base qw[CPANPLUS::Internals::Utils]; |
7 | use base qw[Object::Accessor]; |
8 | |
9 | use Config; |
10 | use Term::UI; |
11 | use Module::Load; |
12 | use Term::ReadLine; |
13 | |
14 | |
15 | use CPANPLUS::Internals::Utils; |
16 | use CPANPLUS::Internals::Constants; |
17 | use CPANPLUS::Error; |
18 | |
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'; |
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 | |
43 | sub 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 | |
85 | sub 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 | |
115 | Welcome to the CPANPLUS configuration. Please select which |
116 | parts you wish to configure |
117 | |
118 | Defaults are taken from your current configuration. |
119 | If 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(" |
134 | Quitting 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(" |
142 | There 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(" |
148 | Quitting 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 |
164 | sub _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[ |
173 | Where would you like to save your CPANPLUS Configuration file? |
174 | |
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. |
178 | |
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. |
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[ |
211 | I see you already have this file: |
212 | %1 |
213 | |
214 | If 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 |
233 | sub _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(" |
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. |
245 | |
246 | For 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(" |
267 | I 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(" |
287 | First 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[ |
339 | Your CPANPLUS build and cache directory has been set to: |
340 | %1 |
341 | |
342 | ], $where); |
343 | |
344 | return 1; |
345 | } |
346 | |
347 | sub _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(" |
357 | If you are connecting through a firewall or proxy that doesn't handle |
358 | FTP 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(" |
384 | CPANPLUS can specify a network timeout for downloads (in whole seconds). |
385 | If 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(" |
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 |
411 | like one. |
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. |
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(" |
440 | You 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(" |
449 | Your '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 |
461 | sub _setup_program { |
462 | my $self = shift; |
463 | my $term = $self->term; |
464 | my $conf = $self->configure_object; |
465 | |
466 | print loc(" |
467 | CPANPLUS can use command line utilities to do certain |
468 | tasks, rather than use perl modules. |
469 | |
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. |
473 | |
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, |
477 | like '%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 | |
530 | sub _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(" |
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. |
541 | |
542 | You can change this setting by making CPANPLUS prefer the use of |
543 | certain 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(" |
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 |
569 | 'makemakerflags' to: |
570 | |
571 | LIB=~/perl/lib INSTALLMAN1DIR=~/perl/man/man1 INSTALLMAN3DIR=~/perl/man/man3 |
572 | |
573 | and be sure that you do NOT set UNINST=1 in 'makeflags' below. |
574 | |
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 |
577 | settings.) |
578 | |
579 | If 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(" |
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. |
603 | |
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. |
606 | |
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 |
609 | settings.) |
610 | |
611 | Again, 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(" |
631 | An alternative to ExtUtils::MakeMaker and Makefile.PL there's a module |
632 | called Module::Build which uses a Build.PL. |
633 | |
634 | If you would like to specify any flags to pass when executing the |
635 | Build.PL (and Build) script, please enter them below. |
636 | |
637 | For instance, if you would like to install modules to your private |
638 | user directory, you could enter: |
639 | |
640 | install_base=/my/private/path |
641 | |
642 | Or to uninstall old copies of modules before updating, you might |
643 | want to enter: |
644 | |
645 | uninst=1 |
646 | |
647 | Again, 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(" |
670 | Some modules provide both a Build.PL (Module::Build) and a Makefile.PL |
671 | (ExtUtils::MakeMaker). By default, CPANPLUS prefers Makefile.PL. |
672 | |
673 | Module::Build support is not bundled standard with CPANPLUS, but |
674 | requires you to install 'CPANPLUS::Dist::Build' from CPAN. |
675 | |
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 |
679 | by Module::Build. |
680 | |
681 | Again, 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(' |
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.) |
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 | |
730 | sub _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(" |
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. |
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(" |
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 |
769 | to 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(" |
793 | Usually, when a test fails, I won't install the module, but if you |
794 | prefer, 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(" |
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. |
821 | |
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.) |
824 | |
825 | If you would like to build modules to satisfy testing or prerequisites, |
826 | but not actually install them, select BUILD. |
827 | |
828 | NOTE: This feature requires you to flush the 'lib' cache for longer |
829 | running programs (refer to the CPANPLUS::Backend documentations for |
830 | more details). |
831 | |
832 | Otherwise, 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(" |
876 | Modules in the CPAN archives are protected with md5 checksums. |
877 | |
878 | This requires the Perl module Digest::MD5 to be installed (which |
879 | CPANPLUS 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(" |
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. |
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(" |
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? |
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(" |
976 | CPANPLUS has support for the Test::Reporter module, which can be utilized |
977 | to report success and failures of modules installed by CPANPLUS. Would |
978 | you like to do this? Note that you will still be prompted before |
979 | sending each report. |
980 | |
981 | If you don't have all the required modules installed yet, you should |
982 | consider installing '%1' |
983 | |
984 | This package bundles all the required modules to enable test reporting |
985 | and querying from CPANPLUS. |
986 | You 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(" |
1010 | The Module::Signature extension allows CPAN authors to sign their |
1011 | distributions using PGP signatures. Would you like to check for |
1012 | module's cryptographic integrity before attempting to install them? |
1013 | Note that this requires either the 'gpg' utility or Crypt::OpenPGP |
1014 | to 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 | |
1035 | sub _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(" |
1049 | I see you already have some hosts selected: |
1050 | |
1051 | $hosts |
1052 | |
1053 | If you'd like to stick with your current settings, just select 'Yes'. |
1054 | Otherwise, 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(" |
1068 | Now we need to know where your favorite CPAN sites are located. Make a |
1069 | list of a few sites (just in case the first on the array won't work). |
1070 | |
1071 | If you are mirroring CPAN to your local workstation, specify a file: |
1072 | URI by picking the CUSTOM option. |
1073 | |
1074 | Otherwise, let us fetch the official CPAN mirror list and you can pick |
1075 | the mirror that suits you best from a list by using the MIRROR option; |
1076 | First, pick a nearby continent and country. Then, you will be presented |
1077 | with a list of URLs of CPAN mirrors in the country you selected. Select |
1078 | one or more of those URLs. |
1079 | |
1080 | Note, the latter option requires a working net connection. |
1081 | |
1082 | You can select VIEW to see your current selection and QUIT when you |
1083 | are 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(" |
1180 | You can enter multiple sites by seperating them by a space. |
1181 | For 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(" |
1221 | If there are any additional URLs you would like to use, please add them |
1222 | now. You may enter them separately or as a space delimited list. |
1223 | |
1224 | We provide a default fall-back URL, but you are welcome to override it |
1225 | with 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 | |
1229 | Note that if you want to use a local depository, you will have to enter |
1230 | as follows: |
1231 | |
1232 | file://server/path/to/cpan |
1233 | |
1234 | if the file is on a server on your local network or as: |
1235 | |
1236 | file:///path/to/cpan |
1237 | |
1238 | if 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(" |
1273 | Where would you like to go now? |
1274 | |
1275 | Please 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(" |
1299 | Your host configuration has been saved |
1300 | |
1301 | "); |
1302 | } |
1303 | |
1304 | return 1; |
1305 | } |
1306 | |
1307 | sub _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 | |
1339 | sub _get_mirrored_by { |
1340 | my $self = shift; |
1341 | my $cpan = $self->backend; |
1342 | my $conf = $self->configure_object; |
1343 | |
1344 | print loc(" |
1345 | Now, we are going to fetch the mirror list for first-time configurations. |
1346 | This 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 | |
1372 | sub _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 | |
1463 | sub _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 | ## |
1491 | sub _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 | |
1595 | 1; |
1596 | |
1597 | |
1598 | sub _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(" |
1607 | I'm sorry, I can't find a suitable editor, so I can't offer you |
1608 | post-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 | |
1620 | sub _save { |
1621 | my $self = shift; |
1622 | my $conf = $self->configure_object; |
1623 | |
1624 | return $conf->save( $self->config_type ); |
1625 | } |
1626 | |
1627 | 1; |