| 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 | |
| 4443dd53 |
214 | The file will not be overwritten until you explicitly save it. |
| 6aaee015 |
215 | |
| 216 | ], $file ); |
| 217 | |
| 218 | redo ASK_CONFIG_TYPE |
| 219 | unless $term->ask_yn( |
| 4443dd53 |
220 | prompt => loc( "Do you wish to use this file?"), |
| 6aaee015 |
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 | ################### |
| 4443dd53 |
972 | ## use sqlite ? ## |
| 973 | ################### |
| 974 | |
| 975 | print loc(" |
| 976 | |
| 977 | To limit the amount of RAM used by CPANPLUS, you can use the SQLite |
| 978 | source backend instead. Note that it is currently still experimental. |
| 979 | Would you like to do this? |
| 980 | |
| 981 | "); |
| 982 | my $type = 'source_engine'; |
| 983 | my $class = 'CPANPLUS::Internals::Source::SQLite'; |
| 984 | my $yn = $term->ask_yn( |
| 985 | prompt => loc("Use SQLite?"), |
| 986 | default => $conf->get_conf( $type ) eq $class ? 1 : 0, |
| 987 | ); |
| 988 | print "\n"; |
| 989 | print $yn |
| 990 | ? loc("I will use SQLite") |
| 991 | : loc("I will not use SQLite"); |
| 992 | |
| 993 | $conf->set_conf( $type => $class ); |
| 994 | } |
| 995 | |
| 996 | { |
| 997 | ################### |
| 6aaee015 |
998 | ## use cpantest? ## |
| 999 | ################### |
| 1000 | |
| 1001 | print loc(" |
| 1002 | CPANPLUS has support for the Test::Reporter module, which can be utilized |
| 1003 | to report success and failures of modules installed by CPANPLUS. Would |
| 1004 | you like to do this? Note that you will still be prompted before |
| 1005 | sending each report. |
| 1006 | |
| 1007 | If you don't have all the required modules installed yet, you should |
| 1008 | consider installing '%1' |
| 1009 | |
| 1010 | This package bundles all the required modules to enable test reporting |
| 1011 | and querying from CPANPLUS. |
| 1012 | You can do so straight after this installation. |
| 1013 | |
| 1014 | ", 'Bundle::CPANPLUS::Test::Reporter'); |
| 1015 | |
| 1016 | my $type = 'cpantest'; |
| 1017 | my $yn = $term->ask_yn( |
| 1018 | prompt => loc('Report test results?'), |
| 1019 | default => $conf->get_conf( $type ) ? 1 : 0, |
| 1020 | ); |
| 1021 | |
| 1022 | print "\n"; |
| 1023 | print $yn |
| 1024 | ? loc("I will prompt you to report test results") |
| 1025 | : loc("I won't prompt you to report test results"); |
| 1026 | |
| 1027 | $conf->set_conf( $type => $yn ); |
| 1028 | } |
| 1029 | |
| 1030 | { |
| 1031 | ################################### |
| 1032 | ## use cryptographic signatures? ## |
| 1033 | ################################### |
| 1034 | |
| 1035 | print loc(" |
| 1036 | The Module::Signature extension allows CPAN authors to sign their |
| 1037 | distributions using PGP signatures. Would you like to check for |
| 1038 | module's cryptographic integrity before attempting to install them? |
| 1039 | Note that this requires either the 'gpg' utility or Crypt::OpenPGP |
| 1040 | to be installed. |
| 1041 | |
| 1042 | "); |
| 1043 | my $type = 'signature'; |
| 1044 | |
| 1045 | my $yn = $term->ask_yn( |
| 1046 | prompt => loc('Shall I check module signatures?'), |
| 1047 | default => $conf->get_conf($type) ? 1 : 0, |
| 1048 | ); |
| 1049 | |
| 1050 | print "\n"; |
| 1051 | print $yn |
| 1052 | ? loc("Ok, I will attempt to check module signatures.") |
| 1053 | : loc("Ok, I won't attempt to check module signatures."); |
| 1054 | |
| 1055 | $conf->set_conf( $type => $yn ); |
| 1056 | } |
| 1057 | |
| 1058 | return 1; |
| 1059 | } |
| 1060 | |
| 1061 | sub _setup_hosts { |
| 1062 | my $self = shift; |
| 1063 | my $term = $self->term; |
| 1064 | my $conf = $self->configure_object; |
| 1065 | |
| 1066 | |
| 1067 | if( scalar @{ $conf->get_conf('hosts') } ) { |
| 1068 | |
| 1069 | my $hosts; |
| 1070 | for my $href ( @{$conf->get_conf('hosts')} ) { |
| 1071 | $hosts .= "\t$href->{scheme}://$href->{host}$href->{path}\n"; |
| 1072 | } |
| 1073 | |
| 1074 | print loc(" |
| 1075 | I see you already have some hosts selected: |
| 1076 | |
| 1077 | $hosts |
| 1078 | |
| 1079 | If you'd like to stick with your current settings, just select 'Yes'. |
| 1080 | Otherwise, select 'No' and you can reconfigure your hosts |
| 1081 | |
| 1082 | "); |
| 1083 | my $yn = $term->ask_yn( |
| 1084 | prompt => loc("Would you like to keep your current hosts?"), |
| 1085 | default => 'y', |
| 1086 | ); |
| 1087 | return 1 if $yn; |
| 1088 | } |
| 1089 | |
| 1090 | my @hosts; |
| 1091 | MAIN: { |
| 1092 | |
| 1093 | print loc(" |
| 1094 | Now we need to know where your favorite CPAN sites are located. Make a |
| 1095 | list of a few sites (just in case the first on the array won't work). |
| 1096 | |
| 1097 | If you are mirroring CPAN to your local workstation, specify a file: |
| 1098 | URI by picking the CUSTOM option. |
| 1099 | |
| 1100 | Otherwise, let us fetch the official CPAN mirror list and you can pick |
| 1101 | the mirror that suits you best from a list by using the MIRROR option; |
| 1102 | First, pick a nearby continent and country. Then, you will be presented |
| 1103 | with a list of URLs of CPAN mirrors in the country you selected. Select |
| 1104 | one or more of those URLs. |
| 1105 | |
| 1106 | Note, the latter option requires a working net connection. |
| 1107 | |
| 1108 | You can select VIEW to see your current selection and QUIT when you |
| 1109 | are done. |
| 1110 | |
| 1111 | "); |
| 1112 | |
| 1113 | my $reply = $term->get_reply( |
| 1114 | prompt => loc('Please choose an option'), |
| 1115 | choices => [qw|Mirror Custom View Quit|], |
| 1116 | default => 'Mirror', |
| 1117 | ); |
| 1118 | |
| 1119 | goto MIRROR if $reply eq 'Mirror'; |
| 1120 | goto CUSTOM if $reply eq 'Custom'; |
| 1121 | goto QUIT if $reply eq 'Quit'; |
| 1122 | |
| 1123 | $self->_view_hosts(@hosts) if $reply eq 'View'; |
| 1124 | redo MAIN; |
| 1125 | } |
| 1126 | |
| 1127 | my $mirror_file; |
| 1128 | my $hosts; |
| 1129 | MIRROR: { |
| 1130 | $mirror_file ||= $self->_get_mirrored_by or return; |
| 1131 | $hosts ||= $self->_parse_mirrored_by($mirror_file) or return; |
| 1132 | |
| 1133 | my ($continent, $country, $host) = $self->_guess_from_timezone( $hosts ); |
| 1134 | |
| 1135 | CONTINENT: { |
| 1136 | my %seen; |
| 1137 | my @choices = sort map { |
| 1138 | $_->{'continent'} |
| 1139 | } grep { |
| 1140 | not $seen{$_->{'continent'}}++ |
| 1141 | } values %$hosts; |
| 1142 | push @choices, qw[Custom Up Quit]; |
| 1143 | |
| 1144 | my $reply = $term->get_reply( |
| 1145 | prompt => loc('Pick a continent'), |
| 1146 | default => $continent, |
| 1147 | choices => \@choices, |
| 1148 | ); |
| 1149 | |
| 1150 | goto MAIN if $reply eq 'Up'; |
| 1151 | goto CUSTOM if $reply eq 'Custom'; |
| 1152 | goto QUIT if $reply eq 'Quit'; |
| 1153 | |
| 1154 | $continent = $reply; |
| 1155 | } |
| 1156 | |
| 1157 | COUNTRY: { |
| 1158 | my %seen; |
| 1159 | my @choices = sort map { |
| 1160 | $_->{'country'} |
| 1161 | } grep { |
| 1162 | not $seen{$_->{'country'}}++ |
| 1163 | } grep { |
| 1164 | ($_->{'continent'} eq $continent) |
| 1165 | } values %$hosts; |
| 1166 | push @choices, qw[Custom Up Quit]; |
| 1167 | |
| 1168 | my $reply = $term->get_reply( |
| 1169 | prompt => loc('Pick a country'), |
| 1170 | default => $country, |
| 1171 | choices => \@choices, |
| 1172 | ); |
| 1173 | |
| 1174 | goto CONTINENT if $reply eq 'Up'; |
| 1175 | goto CUSTOM if $reply eq 'Custom'; |
| 1176 | goto QUIT if $reply eq 'Quit'; |
| 1177 | |
| 1178 | $country = $reply; |
| 1179 | } |
| 1180 | |
| 1181 | HOST: { |
| 1182 | my @list = grep { |
| 1183 | $_->{'continent'} eq $continent and |
| 1184 | $_->{'country'} eq $country |
| 1185 | } values %$hosts; |
| 1186 | |
| 1187 | my %map; my $default; |
| 1188 | for my $href (@list) { |
| 1189 | for my $con ( @{$href->{'connections'}} ) { |
| 1190 | next unless length $con->{'host'}; |
| 1191 | |
| 1192 | my $entry = $con->{'scheme'} . '://' . $con->{'host'}; |
| 1193 | $default = $entry if $con->{'host'} eq $host; |
| 1194 | |
| 1195 | $map{$entry} = $con; |
| 1196 | } |
| 1197 | } |
| 1198 | |
| 1199 | CHOICE: { |
| 1200 | |
| 1201 | ### doesn't play nice with Term::UI :( |
| 1202 | ### should make t::ui figure out pager opens |
| 1203 | #$self->_pager_open; # host lists might be long |
| 1204 | |
| 1205 | print loc(" |
| 1206 | You can enter multiple sites by seperating them by a space. |
| 1207 | For example: |
| 1208 | 1 4 2 5 |
| 1209 | "); |
| 1210 | |
| 1211 | my @reply = $term->get_reply( |
| 1212 | prompt => loc('Please pick a site: '), |
| 1213 | choices => [sort(keys %map), |
| 1214 | qw|Custom View Up Quit|], |
| 1215 | default => $default, |
| 1216 | multi => 1, |
| 1217 | ); |
| 1218 | #$self->_pager_close; |
| 1219 | |
| 1220 | |
| 1221 | goto COUNTRY if grep { $_ eq 'Up' } @reply; |
| 1222 | goto CUSTOM if grep { $_ eq 'Custom' } @reply; |
| 1223 | goto QUIT if grep { $_ eq 'Quit' } @reply; |
| 1224 | |
| 1225 | ### add the host, but only if it's not on the stack already ### |
| 1226 | unless( grep { $_ eq 'View' } @reply ) { |
| 1227 | for my $reply (@reply) { |
| 1228 | if( grep { $_ eq $map{$reply} } @hosts ) { |
| 1229 | print loc("Host '%1' already selected", $reply); |
| 1230 | print "\n\n"; |
| 1231 | } else { |
| 1232 | push @hosts, $map{$reply} |
| 1233 | } |
| 1234 | } |
| 1235 | } |
| 1236 | |
| 1237 | $self->_view_hosts(@hosts); |
| 1238 | |
| 1239 | goto QUIT if $self->autoreply; |
| 1240 | redo CHOICE; |
| 1241 | } |
| 1242 | } |
| 1243 | } |
| 1244 | |
| 1245 | CUSTOM: { |
| 1246 | print loc(" |
| 1247 | If there are any additional URLs you would like to use, please add them |
| 1248 | now. You may enter them separately or as a space delimited list. |
| 1249 | |
| 1250 | We provide a default fall-back URL, but you are welcome to override it |
| 1251 | with e.g. 'http://www.cpan.org/' if LWP, wget or curl is installed. |
| 1252 | |
| 1253 | (Enter a single space when you are done, or to simply skip this step.) |
| 1254 | |
| 1255 | Note that if you want to use a local depository, you will have to enter |
| 1256 | as follows: |
| 1257 | |
| 1258 | file://server/path/to/cpan |
| 1259 | |
| 1260 | if the file is on a server on your local network or as: |
| 1261 | |
| 1262 | file:///path/to/cpan |
| 1263 | |
| 1264 | if the file is on your local disk. Note the three /// after the file: bit |
| 1265 | |
| 1266 | "); |
| 1267 | |
| 1268 | CHOICE: { |
| 1269 | my $reply = $term->get_reply( |
| 1270 | prompt => loc("Additionals host(s) to add: "), |
| 1271 | default => '', |
| 1272 | ); |
| 1273 | |
| 1274 | last CHOICE unless $reply =~ /\S/; |
| 1275 | |
| 1276 | my $href = $self->_parse_host($reply); |
| 1277 | |
| 1278 | if( $href ) { |
| 1279 | push @hosts, $href |
| 1280 | unless grep { |
| 1281 | $href->{'scheme'} eq $_->{'scheme'} and |
| 1282 | $href->{'host'} eq $_->{'host'} and |
| 1283 | $href->{'path'} eq $_->{'path'} |
| 1284 | } @hosts; |
| 1285 | |
| 1286 | last CHOICE if $self->autoreply; |
| 1287 | } else { |
| 1288 | print loc("Invalid uri! Please try again!"); |
| 1289 | } |
| 1290 | |
| 1291 | $self->_view_hosts(@hosts); |
| 1292 | |
| 1293 | redo CHOICE; |
| 1294 | } |
| 1295 | |
| 1296 | DONE: { |
| 1297 | |
| 1298 | print loc(" |
| 1299 | Where would you like to go now? |
| 1300 | |
| 1301 | Please pick one of the following options or Quit when you are done |
| 1302 | |
| 1303 | "); |
| 1304 | my $answer = $term->get_reply( |
| 1305 | prompt => loc("Where to now?"), |
| 1306 | default => 'Quit', |
| 1307 | choices => [qw|Mirror Custom View Quit|], |
| 1308 | ); |
| 1309 | |
| 1310 | if( $answer eq 'View' ) { |
| 1311 | $self->_view_hosts(@hosts); |
| 1312 | redo DONE; |
| 1313 | } |
| 1314 | |
| 1315 | goto MIRROR if $answer eq 'Mirror'; |
| 1316 | goto CUSTOM if $answer eq 'Custom'; |
| 1317 | goto QUIT if $answer eq 'Quit'; |
| 1318 | } |
| 1319 | } |
| 1320 | |
| 1321 | QUIT: { |
| 1322 | $conf->set_conf( hosts => \@hosts ); |
| 1323 | |
| 1324 | print loc(" |
| 1325 | Your host configuration has been saved |
| 1326 | |
| 1327 | "); |
| 1328 | } |
| 1329 | |
| 1330 | return 1; |
| 1331 | } |
| 1332 | |
| 1333 | sub _view_hosts { |
| 1334 | my $self = shift; |
| 1335 | my @hosts = @_; |
| 1336 | |
| 1337 | print "\n\n"; |
| 1338 | |
| 1339 | if( scalar @hosts ) { |
| 1340 | my $i = 1; |
| 1341 | for my $host (@hosts) { |
| 1342 | |
| 1343 | ### show full path on file uris, otherwise, just show host |
| 1344 | my $path = join '', ( |
| 1345 | $host->{'scheme'} eq 'file' |
| 1346 | ? ( ($host->{'host'} || '[localhost]'), |
| 1347 | $host->{path} ) |
| 1348 | : $host->{'host'} |
| 1349 | ); |
| 1350 | |
| 1351 | printf "%-40s %30s\n", |
| 1352 | loc("Selected %1",$host->{'scheme'} . '://' . $path ), |
| 1353 | loc("%quant(%2,host) selected thus far.", $i); |
| 1354 | $i++; |
| 1355 | } |
| 1356 | } else { |
| 1357 | print loc("No hosts selected so far."); |
| 1358 | } |
| 1359 | |
| 1360 | print "\n\n"; |
| 1361 | |
| 1362 | return 1; |
| 1363 | } |
| 1364 | |
| 1365 | sub _get_mirrored_by { |
| 1366 | my $self = shift; |
| 1367 | my $cpan = $self->backend; |
| 1368 | my $conf = $self->configure_object; |
| 1369 | |
| 1370 | print loc(" |
| 1371 | Now, we are going to fetch the mirror list for first-time configurations. |
| 1372 | This may take a while... |
| 1373 | |
| 1374 | "); |
| 1375 | |
| 1376 | ### use the enew configuratoin ### |
| 1377 | $cpan->configure_object( $conf ); |
| 1378 | |
| 1379 | load CPANPLUS::Module::Fake; |
| 1380 | load CPANPLUS::Module::Author::Fake; |
| 1381 | |
| 1382 | my $mb = CPANPLUS::Module::Fake->new( |
| 1383 | module => $conf->_get_source('hosts'), |
| 1384 | path => '', |
| 1385 | package => $conf->_get_source('hosts'), |
| 1386 | author => CPANPLUS::Module::Author::Fake->new( |
| 1387 | _id => $cpan->_id ), |
| 1388 | _id => $cpan->_id, |
| 1389 | ); |
| 1390 | |
| 1391 | my $file = $cpan->_fetch( fetchdir => $conf->get_conf('base'), |
| 1392 | module => $mb ); |
| 1393 | |
| 1394 | return $file if $file; |
| 1395 | return; |
| 1396 | } |
| 1397 | |
| 1398 | sub _parse_mirrored_by { |
| 1399 | my $self = shift; |
| 1400 | my $file = shift; |
| 1401 | |
| 1402 | -s $file or return; |
| 1403 | |
| 1404 | my $fh = new FileHandle; |
| 1405 | $fh->open("$file") |
| 1406 | or ( |
| 1407 | warn(loc('Could not open file "%1": %2', $file, $!)), |
| 1408 | return |
| 1409 | ); |
| 1410 | |
| 1411 | ### slurp the file in ### |
| 1412 | { local $/; $file = <$fh> } |
| 1413 | |
| 1414 | ### remove comments ### |
| 1415 | $file =~ s/#.*$//gm; |
| 1416 | |
| 1417 | $fh->close; |
| 1418 | |
| 1419 | ### sample host entry ### |
| 1420 | # ftp.sun.ac.za: |
| 1421 | # frequency = "daily" |
| 1422 | # dst_ftp = "ftp://ftp.sun.ac.za/CPAN/CPAN/" |
| 1423 | # dst_location = "Stellenbosch, South Africa, Africa (-26.1992 28.0564)" |
| 1424 | # dst_organisation = "University of Stellenbosch" |
| 1425 | # dst_timezone = "+2" |
| 1426 | # dst_contact = "ftpadm@ftp.sun.ac.za" |
| 1427 | # dst_src = "ftp.funet.fi" |
| 1428 | # |
| 1429 | # # dst_dst = "ftp://ftp.sun.ac.za/CPAN/CPAN/" |
| 1430 | # # dst_contact = "mailto:ftpadm@ftp.sun.ac.za |
| 1431 | # # dst_src = "ftp.funet.fi" |
| 1432 | |
| 1433 | ### host name as key, rest of the entry as value ### |
| 1434 | my %hosts = $file =~ m/([a-zA-Z0-9\-\.]+):\s+((?:\w+\s+=\s+".*?"\s+)+)/gs; |
| 1435 | |
| 1436 | while (my($host,$data) = each %hosts) { |
| 1437 | |
| 1438 | my $href; |
| 1439 | map { |
| 1440 | s/^\s*//; |
| 1441 | my @a = split /\s*=\s*/; |
| 1442 | $a[1] =~ s/^"(.+?)"$/$1/g; |
| 1443 | $href->{ pop @a } = pop @a; |
| 1444 | } grep /\S/, split /\n/, $data; |
| 1445 | |
| 1446 | ($href->{city_area}, $href->{country}, $href->{continent}, |
| 1447 | $href->{latitude}, $href->{longitude} ) = |
| 1448 | $href->{dst_location} =~ |
| 1449 | m/ |
| 1450 | #Aizu-Wakamatsu, Tohoku-chiho, Fukushima |
| 1451 | ^"?( |
| 1452 | (?:[^,]+?)\s* # city |
| 1453 | (?: |
| 1454 | (?:,\s*[^,]+?)\s* # optional area |
| 1455 | )*? # some have multiple areas listed |
| 1456 | ) |
| 1457 | |
| 1458 | #Japan |
| 1459 | ,\s*([^,]+?)\s* # country |
| 1460 | |
| 1461 | #Asia |
| 1462 | ,\s*([^,]+?)\s* # continent |
| 1463 | |
| 1464 | # (37.4333 139.9821) |
| 1465 | \((\S+)\s+(\S+?)\)"?$ # (latitude longitude) |
| 1466 | /sx; |
| 1467 | |
| 1468 | ### parse the different hosts, store them in config format ### |
| 1469 | my @list; |
| 1470 | |
| 1471 | for my $type (qw[dst_ftp dst_rsync dst_http]) { |
| 1472 | my $path = $href->{$type}; |
| 1473 | next unless $path =~ /\w/; |
| 1474 | if ($type eq 'dst_rsync' && $path !~ /^rsync:/) { |
| 1475 | $path =~ s{::}{/}; |
| 1476 | $path = "rsync://$path/"; |
| 1477 | } |
| 1478 | my $parts = $self->_parse_host($path); |
| 1479 | push @list, $parts; |
| 1480 | } |
| 1481 | |
| 1482 | $href->{connections} = \@list; |
| 1483 | $hosts{$host} = $href; |
| 1484 | } |
| 1485 | |
| 1486 | return \%hosts; |
| 1487 | } |
| 1488 | |
| 1489 | sub _parse_host { |
| 1490 | my $self = shift; |
| 1491 | my $host = shift; |
| 1492 | |
| 1493 | my @parts = $host =~ m|^(\w*)://([^/]*)(/.*)$|s; |
| 1494 | |
| 1495 | my $href; |
| 1496 | for my $key (qw[scheme host path]) { |
| 1497 | $href->{$key} = shift @parts; |
| 1498 | } |
| 1499 | |
| 1500 | return if lc($href->{'scheme'}) ne 'file' and !$href->{'host'}; |
| 1501 | return if !$href->{'path'}; |
| 1502 | |
| 1503 | return $href; |
| 1504 | } |
| 1505 | |
| 1506 | ## tries to figure out close hosts based on your timezone |
| 1507 | ## |
| 1508 | ## Currently can only report on unique items for each of zones, countries, and |
| 1509 | ## sites. In the future this will be combined with something else (perhaps a |
| 1510 | ## ping?) to narrow down multiple choices. |
| 1511 | ## |
| 1512 | ## Tries to return the best zone, country, and site for your location. Any non- |
| 1513 | ## unique items will be set to undef instead. |
| 1514 | ## |
| 1515 | ## (takes hashref, returns array) |
| 1516 | ## |
| 1517 | sub _guess_from_timezone { |
| 1518 | my $self = shift; |
| 1519 | my $hosts = shift; |
| 1520 | my (%zones, %countries, %sites); |
| 1521 | |
| 1522 | ### autrijus - build time zone table |
| 1523 | my %freq_weight = ( |
| 1524 | 'hourly' => 2400, |
| 1525 | '4 times a day' => 400, |
| 1526 | '4x daily' => 400, |
| 1527 | 'daily' => 100, |
| 1528 | 'twice daily' => 50, |
| 1529 | 'weekly' => 15, |
| 1530 | ); |
| 1531 | |
| 1532 | while (my ($site, $host) = each %{$hosts}) { |
| 1533 | my ($zone, $continent, $country, $frequency) = |
| 1534 | @{$host}{qw/dst_timezone continent country frequency/}; |
| 1535 | |
| 1536 | |
| 1537 | # skip non-well-formed ones |
| 1538 | next unless $continent and $country and $zone =~ /^[-+]?\d+(?::30)?/; |
| 1539 | ### fix style |
| 1540 | chomp $zone; |
| 1541 | $zone =~ s/:30/.5/; |
| 1542 | $zone =~ s/^\+//; |
| 1543 | $zone =~ s/"//g; |
| 1544 | |
| 1545 | $zones{$zone}{$continent}++; |
| 1546 | $countries{$zone}{$continent}{$country}++; |
| 1547 | $sites{$zone}{$continent}{$country}{$site} = $freq_weight{$frequency}; |
| 1548 | } |
| 1549 | |
| 1550 | use Time::Local; |
| 1551 | my $offset = ((timegm(localtime) - timegm(gmtime)) / 3600); |
| 1552 | |
| 1553 | local $_; |
| 1554 | |
| 1555 | ## pick the entry with most country/site/frequency, one level each; |
| 1556 | ## note it has to be sorted -- otherwise we're depending on the hash order. |
| 1557 | ## also, the list context assignment (pick first one) is deliberate. |
| 1558 | |
| 1559 | my ($continent) = map { |
| 1560 | (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) |
| 1561 | } $zones{$offset}; |
| 1562 | |
| 1563 | my ($country) = map { |
| 1564 | (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) |
| 1565 | } $countries{$offset}{$continent}; |
| 1566 | |
| 1567 | my ($site) = map { |
| 1568 | (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_})) |
| 1569 | } $sites{$offset}{$continent}{$country}; |
| 1570 | |
| 1571 | return ($continent, $country, $site); |
| 1572 | } # _guess_from_timezone |
| 1573 | |
| 1574 | |
| 1575 | ### big big regex, stolen to check if you enter a valid address |
| 1576 | { |
| 1577 | my $RFC822PAT; # RFC pattern to match for valid email address |
| 1578 | |
| 1579 | sub _valid_email { |
| 1580 | my $self = shift; |
| 1581 | if (!$RFC822PAT) { |
| 1582 | my $esc = '\\\\'; my $Period = '\.'; my $space = '\040'; |
| 1583 | my $tab = '\t'; my $OpenBR = '\['; my $CloseBR = '\]'; |
| 1584 | my $OpenParen = '\('; my $CloseParen = '\)'; my $NonASCII = '\x80-\xff'; |
| 1585 | my $ctrl = '\000-\037'; my $CRlist = '\012\015'; |
| 1586 | |
| 1587 | my $qtext = qq/[^$esc$NonASCII$CRlist\"]/; |
| 1588 | my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/; |
| 1589 | my $quoted_pair = qq< $esc [^$NonASCII] >; # an escaped character |
| 1590 | my $ctext = qq< [^$esc$NonASCII$CRlist()] >; |
| 1591 | my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >; |
| 1592 | my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >; |
| 1593 | my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >; |
| 1594 | my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/; |
| 1595 | my $atom = qq< $atom_char+ (?!$atom_char) >; |
| 1596 | my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >; |
| 1597 | my $word = qq< (?: $atom | $quoted_str ) >; |
| 1598 | my $domain_ref = $atom; |
| 1599 | my $domain_lit = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >; |
| 1600 | my $sub_domain = qq< (?: $domain_ref | $domain_lit) $X >; |
| 1601 | my $domain = qq< $sub_domain (?: $Period $X $sub_domain)* >; |
| 1602 | my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >; |
| 1603 | my $local_part = qq< $word $X (?: $Period $X $word $X )* >; |
| 1604 | my $addr_spec = qq< $local_part \@ $X $domain >; |
| 1605 | my $route_addr = qq[ < $X (?: $route )? $addr_spec > ]; |
| 1606 | my $phrase_ctrl = '\000-\010\012-\037'; # like ctrl, but without tab |
| 1607 | my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/; |
| 1608 | my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >; |
| 1609 | $RFC822PAT = qq< $X (?: $addr_spec | $phrase $route_addr) >; |
| 1610 | } |
| 1611 | |
| 1612 | return scalar ($_[0] =~ /$RFC822PAT/ox); |
| 1613 | } |
| 1614 | } |
| 1615 | |
| 1616 | |
| 1617 | |
| 1618 | |
| 1619 | |
| 1620 | |
| 1621 | 1; |
| 1622 | |
| 1623 | |
| 1624 | sub _edit { |
| 1625 | my $self = shift; |
| 1626 | my $conf = $self->configure_object; |
| 1627 | my $file = shift || $conf->_config_pm_to_file( $self->config_type ); |
| 1628 | my $editor = shift || $conf->get_program('editor'); |
| 1629 | my $term = $self->term; |
| 1630 | |
| 1631 | unless( $editor ) { |
| 1632 | print loc(" |
| 1633 | I'm sorry, I can't find a suitable editor, so I can't offer you |
| 1634 | post-configuration editing of the config file |
| 1635 | |
| 1636 | "); |
| 1637 | return 1; |
| 1638 | } |
| 1639 | |
| 1640 | ### save the thing first, so there's something to edit |
| 1641 | $self->_save; |
| 1642 | |
| 1643 | return !system("$editor $file"); |
| 1644 | } |
| 1645 | |
| 1646 | sub _save { |
| 1647 | my $self = shift; |
| 1648 | my $conf = $self->configure_object; |
| 1649 | |
| 1650 | return $conf->save( $self->config_type ); |
| 1651 | } |
| 1652 | |
| 1653 | 1; |
projects / p5sagit/p5-mst-13.2.git / blame