cpan/CPANPLUS/lib/CPANPLUS/Configure/Setup.pm

   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 The file will not be overwritten until you explicitly save it.
 215
 216             ], $file );
 217
 218             redo ASK_CONFIG_TYPE
 219                 unless $term->ask_yn(
 220                     prompt  => loc( "Do you wish to use this file?"),
 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'.
 478 ", 'c:\Progra~1\prog.exe' );
 479
 480     for my $prog ( sort $conf->options( type => 'program') ) {
 481         PROGRAM: {
 482             print "\n", loc("Where can I find your '%1' utility? ".
 483                       "(Enter a single space to disable)", $prog ), "\n";
 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
 520                 ? loc(  "Your '%1' utility has been set to '%2'.",
 521                         $prog, $cmd )
 522                 : loc(  "Your '%1' has been disabled.", $prog );
 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 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         ###################
 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;