setup.pm

source of perl for linux application,

now.  You may enter them separately or as a space delimited list.

We provide a default fall-back URL, but you are welcome to override it
with e.g. 'http://www.cpan.org/' if LWP, wget or curl is installed.

(Enter a single space when you are done, or to simply skip this step.)

Note that if you want to use a local depository, you will have to enter
as follows:

file://server/path/to/cpan

if the file is on a server on your local network or as:

file:///path/to/cpan

if the file is on your local disk. Note the three /// after the file: bit

");

        CHOICE: {
            my $reply = $term->get_reply(
                            prompt  => loc("Additionals host(s) to add: "),
                            default => '',
                        );

            last CHOICE unless $reply =~ /\S/;

            my $href = $self->_parse_host($reply);

            if( $href ) {
                push @hosts, $href
                    unless grep {
                        $href->{'scheme'}   eq $_->{'scheme'}   and
                        $href->{'host'}     eq $_->{'host'}     and
                        $href->{'path'}     eq $_->{'path'}
                    } @hosts;

                last CHOICE if $self->autoreply;
            } else {
                print loc("Invalid uri! Please try again!");
            }

            $self->_view_hosts(@hosts);

            redo CHOICE;
        }

        DONE: {

            print loc("
Where would you like to go now?

Please pick one of the following options or Quit when you are done

");
            my $answer = $term->get_reply(
                                    prompt  => loc("Where to now?"),
                                    default => 'Quit',
                                    choices => [qw|Mirror Custom View Quit|],
                                );

            if( $answer eq 'View' ) {
                $self->_view_hosts(@hosts);
                redo DONE;
            }

            goto MIRROR if $answer eq 'Mirror';
            goto CUSTOM if $answer eq 'Custom';
            goto QUIT   if $answer eq 'Quit';
        }
    }

    QUIT: {
        $conf->set_conf( hosts => \@hosts );

        print loc("
Your host configuration has been saved

");
    }

    return 1;
}

sub _view_hosts {
    my $self    = shift;
    my @hosts   = @_;

    print "\n\n";

    if( scalar @hosts ) {
        my $i = 1;
        for my $host (@hosts) {

            ### show full path on file uris, otherwise, just show host
            my $path = join '', (
                            $host->{'scheme'} eq 'file'
                                ? ( ($host->{'host'} || '[localhost]'),
                                    $host->{path} )
                                : $host->{'host'}
                        );

            printf "%-40s %30s\n",
                loc("Selected %1",$host->{'scheme'} . '://' . $path ),
                loc("%quant(%2,host) selected thus far.", $i);
            $i++;
        }
    } else {
        print loc("No hosts selected so far.");
    }

    print "\n\n";

    return 1;
}

sub _get_mirrored_by {
    my $self = shift;
    my $cpan = $self->backend;
    my $conf = $self->configure_object;

    print loc("
Now, we are going to fetch the mirror list for first-time configurations.
This may take a while...

");

    ### use the enew configuratoin ###
    $cpan->configure_object( $conf );

    load CPANPLUS::Module::Fake;
    load CPANPLUS::Module::Author::Fake;

    my $mb = CPANPLUS::Module::Fake->new(
                    module      => $conf->_get_source('hosts'),
                    path        => '',
                    package     => $conf->_get_source('hosts'),
                    author      => CPANPLUS::Module::Author::Fake->new(
                                        _id => $cpan->_id ),
                    _id         => $cpan->_id,
                );

    my $file = $cpan->_fetch(   fetchdir => $conf->get_conf('base'),
                                module   => $mb );

    return $file if $file;
    return;
}

sub _parse_mirrored_by {
    my $self = shift;
    my $file = shift;

    -s $file or return;

    my $fh = new FileHandle;
    $fh->open("$file")
        or (
            warn(loc('Could not open file "%1": %2', $file, $!)),
            return
        );

    ### slurp the file in ###
    { local $/; $file = <$fh> }

    ### remove comments ###
    $file =~ s/#.*$//gm;

    $fh->close;

    ### sample host entry ###
    #     ftp.sun.ac.za:
    #       frequency        = "daily"
    #       dst_ftp          = "ftp://ftp.sun.ac.za/CPAN/CPAN/"
    #       dst_location     = "Stellenbosch, South Africa, Africa (-26.1992 28.0564)"
    #       dst_organisation = "University of Stellenbosch"
    #       dst_timezone     = "+2"
    #       dst_contact      = "[e-mail]"
    #       dst_src          = "ftp.funet.fi"
    #
    #     # dst_dst          = "ftp://ftp.sun.ac.za/CPAN/CPAN/"
    #     # dst_contact      = "mailto:[e-mail]
    #     # dst_src          = "ftp.funet.fi"

    ### host name as key, rest of the entry as value ###
    my %hosts = $file =~ m/([a-zA-Z0-9\-\.]+):\s+((?:\w+\s+=\s+".*?"\s+)+)/gs;

    while (my($host,$data) = each %hosts) {

        my $href;
        map {
            s/^\s*//;
            my @a = split /\s*=\s*/;
            $a[1] =~ s/^"(.+?)"$/$1/g;
            $href->{ pop @a } = pop @a;
        } grep /\S/, split /\n/, $data;

        ($href->{city_area}, $href->{country}, $href->{continent},
            $href->{latitude}, $href->{longitude} ) =
            $href->{dst_location} =~
                m/
                    #Aizu-Wakamatsu, Tohoku-chiho, Fukushima
                    ^"?(
                         (?:[^,]+?)\s*         # city
                         (?:
                             (?:,\s*[^,]+?)\s* # optional area
                         )*?                   # some have multiple areas listed
                     )

                     #Japan
                     ,\s*([^,]+?)\s*           # country

                     #Asia
                     ,\s*([^,]+?)\s*           # continent

                     # (37.4333 139.9821)
                     \((\S+)\s+(\S+?)\)"?$       # (latitude longitude)
                 /sx;

        ### parse the different hosts, store them in config format ###
        my @list;

        for my $type (qw[dst_ftp dst_rsync dst_http]) {
	    my $path = $href->{$type};
	    next unless $path =~ /\w/;
	    if ($type eq 'dst_rsync' && $path !~ /^rsync:/) {
		$path =~ s{::}{/};
		$path = "rsync://$path/";
	    }
            my $parts = $self->_parse_host($path);
            push @list, $parts;
        }

        $href->{connections}    = \@list;
        $hosts{$host}           = $href;
    }

    return \%hosts;
}

sub _parse_host {
    my $self = shift;
    my $host = shift;

    my @parts = $host =~ m|^(\w*)://([^/]*)(/.*)$|s;

    my $href;
    for my $key (qw[scheme host path]) {
        $href->{$key} = shift @parts;
    }

    return if lc($href->{'scheme'}) ne 'file' and !$href->{'host'};
    return if !$href->{'path'};

    return $href;
}

## tries to figure out close hosts based on your timezone
##
## Currently can only report on unique items for each of zones, countries, and
## sites.  In the future this will be combined with something else (perhaps a
## ping?) to narrow down multiple choices.
##
## Tries to return the best zone, country, and site for your location.  Any non-
## unique items will be set to undef instead.
##
## (takes hashref, returns array)
##
sub _guess_from_timezone {
    my $self  = shift;
    my $hosts = shift;
    my (%zones, %countries, %sites);

    ### autrijus - build time zone table
    my %freq_weight = (
        'hourly'        => 2400,
        '4 times a day' =>  400,
        '4x daily'      =>  400,
        'daily'         =>  100,
        'twice daily'   =>   50,
        'weekly'        =>   15,
    );

    while (my ($site, $host) = each %{$hosts}) {
        my ($zone, $continent, $country, $frequency) =
            @{$host}{qw/dst_timezone continent country frequency/};


        # skip non-well-formed ones
        next unless $continent and $country and $zone =~ /^[-+]?\d+(?::30)?/;
        ### fix style
        chomp $zone;
        $zone =~ s/:30/.5/;
        $zone =~ s/^\+//;
        $zone =~ s/"//g;

        $zones{$zone}{$continent}++;
        $countries{$zone}{$continent}{$country}++;
        $sites{$zone}{$continent}{$country}{$site} = $freq_weight{$frequency};
    }

    use Time::Local;
    my $offset = ((timegm(localtime) - timegm(gmtime)) / 3600);

    local $_;

    ## pick the entry with most country/site/frequency, one level each;
    ## note it has to be sorted -- otherwise we're depending on the hash order.
    ## also, the list context assignment (pick first one) is deliberate.

    my ($continent) = map {
        (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
    } $zones{$offset};

    my ($country) = map {
        (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
    } $countries{$offset}{$continent};

    my ($site) = map {
        (sort { ($_->{$b} <=> $_->{$a}) or $b cmp $a } keys(%{$_}))
    } $sites{$offset}{$continent}{$country};

    return ($continent, $country, $site);
} # _guess_from_timezone


### big big regex, stolen to check if you enter a valid address
{
    my $RFC822PAT; # RFC pattern to match for valid email address

    sub _valid_email {
        my $self = shift;
        if (!$RFC822PAT) {
            my $esc        = '\\\\'; my $Period      = '\.'; my $space      = '\040';
            my $tab         = '\t';  my $OpenBR     = '\[';  my $CloseBR    = '\]';
            my $OpenParen  = '\(';   my $CloseParen  = '\)'; my $NonASCII   = '\x80-\xff';
            my $ctrl        = '\000-\037';                   my $CRlist     = '\012\015';

            my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
            my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
            my $quoted_pair = qq< $esc [^$NonASCII] >; # an escaped character
            my $ctext   = qq< [^$esc$NonASCII$CRlist()] >;
            my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >;
            my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >;
            my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >;
            my $atom_char  = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
            my $atom = qq< $atom_char+ (?!$atom_char) >;
            my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >;
            my $word = qq< (?: $atom | $quoted_str ) >;
            my $domain_ref  = $atom;
            my $domain_lit  = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >;
            my $sub_domain  = qq< (?: $domain_ref | $domain_lit) $X >;
            my $domain = qq< $sub_domain (?: $Period $X $sub_domain)* >;
            my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;
            my $local_part = qq< $word $X (?: $Period $X $word $X )* >;
            my $addr_spec  = qq< $local_part \@ $X $domain >;
            my $route_addr = qq[ < $X (?: $route )?  $addr_spec > ];
            my $phrase_ctrl = '\000-\010\012-\037'; # like ctrl, but without tab
            my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
            my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >;
            $RFC822PAT = qq< $X (?: $addr_spec | $phrase $route_addr) >;
        }

        return scalar ($_[0] =~ /$RFC822PAT/ox);
    }
}






1;


sub _edit {
    my $self    = shift;
    my $conf    = $self->configure_object;
    my $file    = shift || $conf->_config_pm_to_file( $self->config_type );
    my $editor  = shift || $conf->get_program('editor');
    my $term    = $self->term;

    unless( $editor ) {
        print loc("
I'm sorry, I can't find a suitable editor, so I can't offer you
post-configuration editing of the config file

");
        return 1;
    }

    ### save the thing first, so there's something to edit
    $self->_save;

    return !system("$editor $file");
}

sub _save {
    my $self = shift;
    my $conf = $self->configure_object;
    
    return $conf->save( $self->config_type );
}    

1;