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