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