Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine

CPAN Mirror locator

by Anonymous Monk
on Jun 09, 2001 at 03:15 UTC ( #87117=snippet: print w/replies, xml ) Need Help??
Description: pings the list of CPAN Mirrors in MIRRORED.BY to determine the fastest/nearest mirror.
#!/usr/bin/perl -w

# amount of stuff to spit out while processing
my $verbosity    = 1;            # 0-3

# microseconds for ping timeout (1_000_000 = 1 sec)
# the lower TIMEOUT is, the more X's you'll see
my $TIMEOUT    = 500_000;        # .5 seconds
#my $TIMEOUT    = 2_500_000;        # 2.5 seconds
#my $TIMEOUT    = 4_000_000;        # 4 seconds

# number of top pings to show (and to write to CPAN::Config)
my $showTop    = 25;

# Don't Touch!!!

use strict;
use vars qw/ $ABORT /;
use Net::hostent ();
use Net::Ping ();
use Socket ();
use CPAN ();    # loads ExtUtils::MakeMaker (MM used later)

# in case they don't have Time::HiRes
my $Timer = 1;
eval {
    require Time::HiRes;
if ($@) {
    if ($@ =~ m/can't locate/i) {
    $Timer = getHiRes() or exit;
    } else {
    print "Unknown Error: $@\n";

# can you tell I don't like default imports?

Net::hostent->import(qw/ gethost /);
Socket->import(qw/ inet_ntoa /);


if ($Timer == 1) {
    Time::HiRes->import(qw/ ualarm gettimeofday tv_interval /);
} elsif ($Timer == 2) {
    print "\n";
    print "I'll try and use another method, but it'll be\n";
    print "far less inaccurate (Actually pretty useless).\n";

    *ualarm = sub { $_[0] ? alarm $_[0] / 1_000_000 + 1 : alarm 0 };
    *gettimeofday = sub { time };
    *tv_interval = sub { (time - $_[0]->[0] + 1) / 1000 };
} else {
    die "Unknown Error: Timer inefficiencies\n";

#*gethost = \&Net::hostent::gethost;    # manually import gethost
#*inet_ntoa = \&Socket::inet_ntoa;    # manually import inet_ntoa

sub trim(;$);    # pass it an arg, or it operates on $_

my $MIRRORED_BY = MM->catfile($CPAN::Config->{keep_source_where}, 'MIR

unless (-e $MIRRORED_BY) {
    # hmm, this shouldn't happen unless CPAN isn't installed
    print "Couldn't find MIRRORED.BY file!\n";

my $start = [gettimeofday()];

unless (open MIRRORS, "<$MIRRORED_BY") {
    print "Unable to read from $MIRRORED_BY [$!]\n";

my $mirrors = {};
my $site = 'unknown';
my $wide = 0;
my $wide2 = 0;

# we don't need all of the data that this loads, we really only care a
+bout dst_dst
# but it is a decent reference for parsing the MIRRORED.BY file

while (<MIRRORS>) {
    next if /^$/ || /^\s+$/;    # skip blank lines (found space on lin
+e 199)
    next if /^#/ && !/dst_dst/;    # skip comments that 

    ($site = $1) && next if m/^([\w\.-]+):/;
    $wide = length $site if length $site > $wide;
    my ($k, $v) = split /=/, trim;
    $mirrors->{$site}->{$k} = $v;

close MIRRORS;

my $default_ip        = '';    # so we can catch the domains that were
+n't properly resolved

# this will resolve to the default domain (i.e.
if (my $h = gethost("")) {
    $default_ip = inet_ntoa($h->addr);

print 'Going to ping ', scalar keys %$mirrors, " sites\n" if $verbosit

# cause this can take a while....
$SIG{INT} = sub {
    print "\n\nCaught SIGINT\n";
    $verbosity = 0;        # turn off messages
    $ABORT++;            # set ABORT flag
    ualarm(0);            # kill any alarms
    $SIG{ALRM} = 'IGNORE';
    die 'Cancelled';

eval {
if ($@) {
    if ($@ =~ m/Cancelled/) {
    print "Pinging cancelled.  Generating summary...\n\n";
    } else {
    print "Unknown Error: $@\n";


sub trim(;$) {
    local $_ = shift || $_;
    return $_;

sub pingSites {
    my $sites = shift;

    my $count = 0;
    my $thresh = 50;
    local $SIG{ALRM} = sub { die 'Alarm' };
    my $p = Net::Ping->new('icmp');
    foreach (values %$sites) {
    return if $ABORT;

    print "\n" if $verbosity && $count++ % $thresh == 0;

    my ($dom, $ip);
    $dom = $ip = $_->{ftp_dom} = getDomain($_->{dst_dst});

    $wide2 = length $dom if length $dom > $wide2;

    eval {
        ualarm(500_000);    # give half second to resolve domain
        if (my $h = gethost($dom)) {
        $ip = inet_ntoa($h->addr);
    if ($@) {
        die unless $@ =~ m/Alarm/;
        print 'x' if $verbosity;
        print "'$dom' -> dns timed out\n" if $verbosity >= 2;
        $_->{pingRate} = 9999.999;
    if ($default_ip && $default_ip eq $ip) {
        # $dom didn't resolve properly
        print '=' if $verbosity;
        print "'$dom' -> didn't resolve properly\n" if $verbosity >= 2
        $_->{pingRate} = 9999.999;

    eval {
        my $start = [gettimeofday()];
        $_->{pingRate} = tv_interval($start) * 1000;
    if ($@) {
        die unless $@ =~ m/Alarm/;
        print 'X' if $verbosity;
        print "'$dom' -> ping timed out\n" if $verbosity >= 2;
        $_->{pingRate} = 999.999;

    if ($verbosity) {
        print '.';

    print "!\n" if $verbosity;

sub getDomain {
    local $_    = shift;
    print "clean '$_'\n" if $verbosity >= 3;
    $_ = (m/(([\w-]+\.)+\w\w+)/o)[0];
    print "cleaned '$_'\n" if $verbosity >= 3;
    return $_;

    my $RAN = 0;
    sub printResults {
    return if $RAN++;

    my $mirrors = shift;

    local $;    # disable warnings...

    my $count = 1;
    my @topSites;

    printf " %-${wide}s     %8s   %${wide2}s\n", 'CPAN Site', 'Time', 
    printf " %-${wide}s     %8s   %${wide2}s\n", '---------', '----', 
    foreach (sort { $mirrors->{$a}->{pingRate} <=> $mirrors->{$b}->{pi
+ngRate} } keys %$mirrors) {
        next unless exists $mirrors->{$_}->{pingRate};
        push @topSites, $mirrors->{$_};
        printf "%2d %-${wide}s     %8s   %${wide2}s\n", $count, $_, $m
+irrors->{$_}->{pingRate}, $mirrors->{$_}->{ftp_dom};
        last if $count++ == $showTop;

    print "\nTime Running: ", tv_interval($start), " sec\n";

    undef $mirrors;

    promptSave(\@topSites) if @topSites; 

sub promptSave {
    my $topSites    = shift;

    print "Shall I write the top $showTop to the CPAN Config? [y/N]";
    if (<STDIN> =~ m/^y/i) {
    @{ $CPAN::Config->{urllist} } = map { $_->{dst_dst} } @$topSites;


sub getHiRes {

    print "I wasn't able to load Time::HiRes. Would you like me to att
+empt to\n",
    "download it from CPAN? [y]";

    if (<STDIN> =~ m/^n/i) {
    return 2;


    # and try one more time
    eval {
    require Time::HiRes;
    if ($@) {
    if ($@ =~ m/can't locate/i) {
        print "Guess I wasn't able to install Time::HiRes for you. Sor
        return 2;
    } else {
        print "Unknow Error: $@\n";
        return 0;

    # success! we installed Time::HiRes
    return 1;


# Documentation Follows


=head1 NAME - find the nearest/fastest CPAN server to local machine

=head1 VERSION





=head2 Overview

This script will generate a list of CPAN Mirrors that
have the lowest return time of an ICMP ping.

It then prompts whether or not to write that list out
to CPAN::Config

=head2 Options

There are a couple of vars you can set at the top
of the script to tweak how it runs:

=over 4

=item o


=over 4

How much info do you want returned (0-3)
(See L<"Output">)


=item o


=over 4

The length of time before giving up on a ping.
Values are in microseconds (ie. 4_000_000 = 4 sec)


=item o


=over 4

Number of sites to display, and, upon approval, write
to CPAN::Config



=head2 Output

This is what you'll see from the various verbose values;
(Note: These are inclusive)

=over 4

=item o


=over 4

Nothing (isn't that nice!)


=item o


=over 4

Number of sites to be pinged

Symbols for each ping attempt:

=over 4

=item *

'.' - Successful ping

=item *

'x' - DNS timeout

=item *

'X' - Ping timeout

=item *

'=' - DNS resolve error


And when the pinging is done you'll see '!'.


=item o


=over 4

Messages stating the domain and the problem (if any)


=item o


=over 4

'Before and after' parsing of domain to be pinged



=head1 Prerequisites

These are the files required to run this script:

=over 4

=item *

CPAN - comes with perl

=item *

Net::hostent - comes with perl

=item *

Net::Ping - comes with perl

=item *

Socket - comes with perl

=item *

Time::HiRes - available from CPAN

=over 4

If Time::HiRes is not on your system, this script will prompt
you to download and install it from CPAN



=head1 TODO

This could be modularized and placed into the CPAN::* namespace.
We'll see how receptive the community is.

=head1 BUGS

I didn't try to make any, so there shouldn't be any.
Although DO let me know if there are.

=head1 AUTHOR(S)

Scott Wessels (


Copyright (c) 2001, Scott Wessels. All Rights Reserved.
This module is free software. It may be used, redistributed
and/or modified under the same terms as Perl itself.

Replies are listed 'Best First'.
Re: CPAN Mirror locator
by Intrepid (Deacon) on Jul 25, 2003 at 07:03 UTC
    I downloaded the code and ran it through `perl -c {file}'. There is a bad character at what is Line 227 for me and I will try to show it with enough context so it should be easy to spot:

    sub printResults { return if $RAN++; my $mirrors = shift; local $; # disable warnings... my $count = 1; my @topSites;

    The line that looks like

        local $;    # disable warnings...
    is the problem. Maybe someone else knows how this crept in there but I don't.

    I could be wrong but I might guess that this will fix it up right:

    local $^W = undef ; # turn off warnings

    This isn't a "snippet" but a full-fledged application. I was looking for something like this a few months ago and couldn't find it (of COURSE) and so I wrote my own.

    I found this non-snippet by looking through grinder's Index of Snippets.

    If the poster (Scott Wessels) is still a Monk (Anonymous or otherwise) and reads this, I hope he'll contact me about my version of this tool.

       Soren Andersen

      OK, checking back, I see a chance to burn some XP. Yay! I've got something to say about Perl Monks in general here.

      At the time of this follow-up, this node (my reply to the root node) is given a XP rating of -1. I am perplexed at the appearance of the sort of person among the ranks of Perl Monks who would downvote this well-intentioned commentary (with a code fix!) without so much as showing the courtesy to offer the briefest critique explaining their actions, so that the author can understand how s/he failed and work for self-improvement.

      Hopefully this kind of thing won't become too commonplace. I don't obsess over my XP but the chilling affect exerted by this kind of unexplained, irresponsible use of the XP system could wind up dissuading people who are sensitive to criticism from contributing.


      use PerlMonk::Tye qw(:wisely);

        Thank you for your fix.

        I was puzzled by this error, as perl told me it was on line 255, and I could only find an empty line (a linefeed) at that location.

        With the help of your snippet, I was able to find the offending line, and replace it with your fix.


Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: snippet [id://87117]
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (2)
As of 2019-04-21 08:40 GMT
Find Nodes?
    Voting Booth?
    I am most likely to install a new module from CPAN if:

    Results (110 votes). Check out past polls.

    • (Sep 10, 2018 at 22:53 UTC) Welcome new users!