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";
exit;
}
}
# can you tell I don't like default imports?
Net::hostent->import(qw/ gethost /);
Socket->import(qw/ inet_ntoa /);
CPAN::Config->load();
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
+RORED.BY');
unless (-e $MIRRORED_BY) {
# hmm, this shouldn't happen unless CPAN isn't installed
print "Couldn't find MIRRORED.BY file!\n";
exit;
}
my $start = [gettimeofday()];
unless (open MIRRORS, "<$MIRRORED_BY") {
print "Unable to read from $MIRRORED_BY [$!]\n";
exit;
}
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. no.such.host.domain.co
+m)
if (my $h = gethost("no.such.host")) {
$default_ip = inet_ntoa($h->addr);
}
print 'Going to ping ', scalar keys %$mirrors, " sites\n" if $verbosit
+y;
# 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 {
pingSites($mirrors);
};
if ($@) {
if ($@ =~ m/Cancelled/) {
print "Pinging cancelled. Generating summary...\n\n";
} else {
print "Unknown Error: $@\n";
}
}
printResults($mirrors);
sub trim(;$) {
local $_ = shift || $_;
chomp;
s/^#//o;
s/^\s+//o;
s/\s+$//o;
s/\s+=\s+/=/o;
s/"//go;
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);
}
ualarm(0);
};
if ($@) {
die unless $@ =~ m/Alarm/;
print 'x' if $verbosity;
print "'$dom' -> dns timed out\n" if $verbosity >= 2;
$_->{pingRate} = 9999.999;
next;
}
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;
next;
}
eval {
ualarm($TIMEOUT);
my $start = [gettimeofday()];
$p->ping($ip);
$_->{pingRate} = tv_interval($start) * 1000;
ualarm(0);
};
if ($@) {
die unless $@ =~ m/Alarm/;
print 'X' if $verbosity;
print "'$dom' -> ping timed out\n" if $verbosity >= 2;
$_->{pingRate} = 999.999;
next;
}
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',
+'FTP';
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;
CPAN::Config->commit();
}
}
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;
}
CPAN::Shell->install("Time::HiRes");
# 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
+ry\n";
return 2;
} else {
print "Unknow Error: $@\n";
return 0;
}
}
# success! we installed Time::HiRes
return 1;
}
# Documentation Follows
=pod
=head1 NAME
cpan_search.pl - find the nearest/fastest CPAN server to local machine
=head1 VERSION
1.0
=head1 SYNOPSIS
perl cpan_search.pl
=head1 DESCRIPTION
=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
verbosity
=over 4
How much info do you want returned (0-3)
(See L<"Output">)
=back
=item o
TIMEOUT
=over 4
The length of time before giving up on a ping.
Values are in microseconds (ie. 4_000_000 = 4 sec)
=back
=item o
showTop
=over 4
Number of sites to display, and, upon approval, write
to CPAN::Config
=back
=back
=head2 Output
This is what you'll see from the various verbose values;
(Note: These are inclusive)
=over 4
=item o
0
=over 4
Nothing (isn't that nice!)
=back
=item o
1
=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
=back
And when the pinging is done you'll see '!'.
=back
=item o
2
=over 4
Messages stating the domain and the problem (if any)
=back
=item o
3
=over 4
'Before and after' parsing of domain to be pinged
=back
=back
=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
=back
=back
=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 (swessels@usgn.net)
=head1 COPYRIGHT
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.
=cut
