[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/CPANPLUS/Configure/ -> Setup.pm (source)

   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;


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1