home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / CPANPLUS / Configure / Setup.pm
Encoding:
Perl POD Document  |  2009-06-26  |  49.2 KB  |  1,628 lines

  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;
  1628.