perl 5.16.2, compiled without optimization for Windows (from siep)

git-svn-id: svn://tug.org/texlive/trunk@28315 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 356 insertions, 83 deletions

diff --git a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
index 3582b0acb4c..daafc1dbaf1 100644
--- a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
+++ b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
@@ -1,5 +1,37 @@
 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
 # vim: ts=4 sts=4 sw=4:
+=head1 NAME
+
+CPAN::Mirrors - Get CPAN miror information and select a fast one
+
+=head1 SYNOPSIS
+
+	use CPAN::Mirrors;
+
+	my $mirrors = CPAN::Mirrors->new;
+	$mirrors->parse_from_file( $mirrored_by_file );
+
+	my $seen = {};
+
+	my $best_continent = $mirrors->find_best_continents( { seen => $seen } );
+	my @mirrors        = $mirrors->get_mirrors_by_continents( $best_continent );
+
+	my $callback = sub {
+		my( $m ) = @_;
+		printf "%s = %s\n", $m->hostname, $m->rtt
+		};
+	$mirrors->get_mirrors_timings( \@mirrors, $seen, $callback );
+
+	@mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
+
+	print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";
+
+=head1 DESCRIPTION
+
+=over
+
+=cut
+
 package CPAN::Mirrors;
 use strict;
 use vars qw($VERSION $urllist $silent);
@@ -10,31 +42,55 @@ use FileHandle;
 use Fcntl ":flock";
 use Net::Ping ();
 
+=item new( LOCAL_FILE_NAME )
+
+=cut
+
 sub new {
     my ($class, $file) = @_;
-    my $self = bless { 
-        mirrors => [], 
-        geography => {},
+    my $self = bless {
+        mirrors      => [],
+        geography    => {},
     }, $class;
 
+	if( defined $file ) {
+		$self->parse_mirrored_by( $file );
+	}
+
+    return $self
+}
+
+sub parse_mirrored_by {
+	my ($self, $file) = @_;
     my $handle = FileHandle->new;
-    $handle->open($file) 
+    $handle->open($file)
         or croak "Couldn't open $file: $!";
     flock $handle, LOCK_SH;
     $self->_parse($file,$handle);
     flock $handle, LOCK_UN;
     $handle->close;
+}
 
-    # populate continents & countries
+=item continents()
 
-    return $self
-}
+Return a list of continents based on those defined in F<MIRRORED.BY>.
+
+=cut
 
 sub continents {
     my ($self) = @_;
     return keys %{$self->{geography}};
 }
 
+=item countries( [CONTINENTS] )
+
+Return a list of countries based on those defined in F<MIRRORED.BY>.
+It only returns countries for the continents you specify (as defined
+in C<continents>). If you don't specify any continents, it returns all
+of the countries listed in F<MIRRORED.BY>.
+
+=cut
+
 sub countries {
     my ($self, @continents) = @_;
     @continents = $self->continents unless @continents;
@@ -45,6 +101,15 @@ sub countries {
     return @countries;
 }
 
+=item mirrors( [COUNTRIES] )
+
+Return a list of mirrors based on those defined in F<MIRRORED.BY>.
+It only returns mirrors for the countries you specify (as defined
+in C<countries>). If you don't specify any countries, it returns all
+of the mirrors listed in F<MIRRORED.BY>.
+
+=cut
+
 sub mirrors {
     my ($self, @countries) = @_;
     return @{$self->{mirrors}} unless @countries;
@@ -56,118 +121,300 @@ sub mirrors {
     return @found;
 }
 
+=item get_mirrors_by_countries( [COUNTRIES] )
+
+A more sensible synonym for mirrors.
+
+=cut
+
+sub get_mirrors_by_countries { &mirrors }
+
+=item get_mirrors_by_continents( [CONTINENTS] )
+
+Return a list of mirrors for all of continents you specify. If you don't
+specify any continents, it returns all of the mirrors.
+
+=cut
+
+sub get_mirrors_by_continents {
+	my ($self, $continents ) = @_;
+
+	$self->mirrors( $self->get_countries_by_continents( @$continents ) );
+	}
+
+=item get_countries_by_continents( [CONTINENTS] )
+
+A more sensible synonym for countries.
+
+=cut
+sub get_countries_by_continents { &countries }
+
+=item best_mirrors
+
+C<best_mirrors> checks for the best mirrors based on the list of
+continents you pass, or, without that, all continents, as defined
+by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of
+C<how_many>. In list context, it returns up to C<how_many> mirror.
+In scalar context, it returns the single best mirror.
+
+Arguments
+
+	how_many   - the number of mirrors to return. Default: 1
+	callback   - a callback for find_best_continents
+	verbose    - true or false on all the whining and moaning. Default: false
+	continents - an array ref of the continents to check
+
+If you don't specify the continents, C<best_mirrors> calls
+C<find_best_continents> to get the list of continents to check.
+
+=cut
+
 sub best_mirrors {
     my ($self, %args) = @_;
-    my $how_many = $args{how_many} || 1;
-    my $callback = $args{callback};
-    my $verbose = $args{verbose};
-    my $conts = $args{continents} || [];
-    $conts = [$conts] unless ref $conts;
+    my $how_many      = $args{how_many} || 1;
+    my $callback      = $args{callback};
+    my $verbose       = defined $args{verbose} ? $args{verbose} : 0;
+    my $continents    = $args{continents} || [];
+       $continents    = [$continents] unless ref $continents;
 
     # Old Net::Ping did not do timings at all
     return "http://www.cpan.org/" unless Net::Ping->VERSION gt '2.13';
 
     my $seen = {};
 
-    if ( ! @$conts ) {
+    if ( ! @$continents ) {
         print "Searching for the best continent ...\n" if $verbose;
-        my @best = $self->_find_best_continent($seen, $verbose, $callback);
+        my @best_continents = $self->find_best_continents(
+        	seen     => $seen,
+        	verbose  => $verbose,
+        	callback => $callback,
+        	);
 
         # Only add enough continents to find enough mirrors
         my $count = 0;
-        for my $c ( @best ) {
-            push @$conts, $c;
-            $count += $self->mirrors( $self->countries($c) );
+        for my $continent ( @best_continents ) {
+            push @$continents, $continent;
+            $count += $self->mirrors( $self->countries($continent) );
             last if $count >= $how_many;
         }
     }
 
-    print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose;
+    print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;
+
+	my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );
+
+    my $timings = $self->get_mirrors_timings( $trial_mirrors, $seen, $callback );
+    return [] unless @$timings;
+
+    $how_many = @$timings if $how_many > @$timings;
+
+    return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0];
+}
+
+=item get_n_random_mirrors_by_continents( N, [CONTINENTS]
+
+Returns up to N random mirrors for the specified continents. Specify the
+continents as an array reference.
+
+=cut
+
+sub get_n_random_mirrors_by_continents {
+	my( $self, $n, $continents ) = @_;
+	$n ||= 3;
+	$continents = [ $continents ] unless ref $continents;
 
-    my @timings;
-    my @long_list = $self->mirrors($self->countries(@$conts));
-    my $long_list_size = ( $how_many > 10 ? $how_many : 10 );
-    if ( @long_list > $long_list_size ) {
-        @long_list = map  {$_->[0]}
-                     sort {$a->[1] <=> $b->[1]}
-                     map  {[$_, rand]} @long_list;
-        splice @long_list, $long_list_size; # truncate
+    if ( $n <= 0 ) {
+    	return wantarray ? () : [];
     }
 
-    for my $m ( @long_list ) {
-        next unless $m->http;
-        my $hostname = $m->hostname;
-        if ( $seen->{$hostname}  ) {
-            push @timings, $seen->{$hostname}
-                if defined $seen->{$hostname}[1];
+    my @long_list = $self->get_mirrors_by_continents( $continents );
+
+    if ( $n eq '*' or $n > @long_list ) {
+    	return wantarray ? @long_list : \@long_list;
+    }
+
+	@long_list = map  {$_->[0]}
+	             sort {$a->[1] <=> $b->[1]}
+                 map  {[$_, rand]} @long_list;
+
+	splice @long_list, $n; # truncate
+
+	\@long_list;
+}
+
+=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK );
+
+Pings the listed mirrors and returns a list of mirrors sorted
+in ascending ping times.
+
+=cut
+
+sub get_mirrors_timings {
+	my( $self, $mirror_list, $seen, $callback ) = @_;
+
+	$seen = {} unless defined $seen;
+	croak "The mirror list argument must be an array reference"
+		unless ref $mirror_list eq ref [];
+	croak "The seen argument must be a hash reference"
+		unless ref $seen eq ref {};
+	croak "callback must be a subroutine"
+		if( defined $callback and ref $callback ne ref sub {} );
+
+	my $timings = [];
+    for my $m ( @$mirror_list ) {
+		$seen->{$m->hostname} = $m;
+		next unless eval{ $m->http };
+
+        if( $self->_try_a_ping( $seen, $m, ) ) {
+            my $ping = $m->ping;
+			next unless defined $ping;
+            push @$timings, $m;
+            $callback->( $m ) if $callback;
         }
         else {
-            my $ping = $m->ping;
-            next unless defined $ping;
-            push @timings, [$m, $ping];
-            $callback->($m,$ping) if $callback;
+            push @$timings, $seen->{$m->hostname}
+                if defined $seen->{$m->hostname}->rtt;
         }
     }
-    return unless @timings;
-
-    $how_many = @timings if $how_many > @timings;
-    my @best =
-        map  { $_->[0] }
-        sort { $a->[1] <=> $b->[1] } @timings;
 
-    return wantarray ? @best[0 .. $how_many-1] : $best[0];
+    my @best = sort {
+    	   if( defined $a->rtt and defined $b->rtt )     {
+    		$a->rtt <=> $b->rtt
+    		}
+    	elsif( defined $a->rtt and ! defined $b->rtt )   {
+    		return -1;
+    		}
+    	elsif( ! defined $a->rtt and defined $b->rtt )   {
+    		return 1;
+    		}
+    	elsif( ! defined $a->rtt and ! defined $b->rtt ) {
+    		return 0;
+    		}
+
+    	} @$timings;
+
+    return wantarray ? @best : \@best;
 }
 
-sub _find_best_continent {
-    my ($self, $seen, $verbose, $callback) = @_;
+=item find_best_continents( HASH_REF );
+
+C<find_best_continents> goes through each continent and pings C<N> random
+mirrors on that continent. It then orders the continents by ascending
+median ping time. In list context, it returns the ordered list of
+continent. In scalar context, it returns the same list as an anonymous
+array.
+
+Arguments:
+
+	n        - the number of hosts to ping for each continent. Default: 3
+	seen     - a hashref of cached hostname ping times
+	verbose  - true or false for noisy or quiet. Default: false
+	callback - a subroutine to run after each ping.
+	ping_cache_limit - how long, in seconds, to reuse previous ping times.
+		Default: 1 day
+
+The C<seen> hash has hostnames as keys and anonymous arrays as values. The
+anonymous array is a triplet of a C<CPAN::Mirrored::By> object, a ping
+time, and the epoch time for the measurement.
+
+The callback subroutine gets the C<CPAN::Mirrored::By> object, the ping
+time, and measurement time (the same things in the C<seen> hashref) as arguments.
+C<find_best_continents> doesn't care what the callback does and ignores the return
+value.
 
-    my %median;
+=cut
+
+sub find_best_continents {
+    my ($self, %args) = @_;
+
+	$args{n}     ||=  3;
+	$args{verbose} = 0 unless defined $args{verbose};
+	$args{seen}    = {} unless defined $args{seen};
+	croak "The seen argument must be a hash reference"
+		unless ref $args{seen} eq ref {};
+	$args{ping_cache_limit} = 24 * 60 * 60
+		unless defined $args{ping_cache_time};
+	croak "callback must be a subroutine"
+		if( defined $args{callback} and ref $args{callback} ne ref sub {} );
+
+    my %medians;
     CONT: for my $c ( $self->continents ) {
+    	print "Testing $c\n" if $args{verbose};
         my @mirrors = $self->mirrors( $self->countries($c) );
+
         next CONT unless @mirrors;
-        my $sample = 3;
-        my $n = (@mirrors < $sample) ? @mirrors : $sample;
+        my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};
+
         my @tests;
-        RANDOM: while ( @mirrors && @tests < $n ) {
+        my $tries = 0;
+        RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
             my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
-            my $ping = $m->ping;
-            $callback->($m,$ping) if $callback;
-            # record undef so we don't try again
-            $seen->{$m->hostname} = [$m, $ping];
-            next RANDOM unless defined $ping;
-            push @tests, $ping;
-        }
-        next CONT unless @tests;
-        @tests = sort { $a <=> $b } @tests;
-        if ( @tests == 1 ) {
-            $median{$c} = $tests[0];
-        }
-        elsif ( @tests % 2 ) {
-            $median{$c} = $tests[ int(@tests / 2) ];
-        }
-        else {
-            my $mid_high = int(@tests/2);
-            $median{$c} = ($tests[$mid_high-1] + $tests[$mid_high])/2;
+           if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) {
+				$self->get_mirrors_timings( [ $m ], @args{qw(seen callback)} );
+				next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
+            }
+            printf "\t%s -> %0.2f ms\n",
+            	$m->hostname,
+            	join ' ', 1000 * $args{seen}{$m->hostname}->rtt
+            		if $args{verbose};
+
+			push @tests, $args{seen}{$m->hostname}->rtt;
         }
+
+		my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
+		$medians{$c} = $median if defined $median;
     }
 
-    my @best_cont = sort { $median{$a} <=> $median{$b} } keys %median ;
+    my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians;
 
-    if ( $verbose ) {
+    if ( $args{verbose} ) {
         print "Median result by continent:\n";
         for my $c ( @best_cont ) {
-            printf( "  %d ms  %s\n", int($median{$c}*1000+.5), $c );
+            printf( "  %4d ms  %s\n", int($medians{$c}*1000+.5), $c );
         }
     }
 
     return wantarray ? @best_cont : $best_cont[0];
 }
 
+# retry if
+sub _try_a_ping {
+	my ($self, $seen, $mirror, $ping_cache_limit ) = @_;
+
+	( ! exists $seen->{$mirror->hostname} )
+		or
+	(
+	! defined $seen->{$mirror->hostname}->rtt
+		or
+	time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit
+	)
+}
+
+sub _get_median_ping_time {
+	my ($self, $tests, $verbose ) = @_;
+
+	my @sorted = sort { $a <=> $b } @$tests;
+
+	my $median = do {
+		   if ( @sorted == 0 ) { undef }
+		elsif ( @sorted == 1 ) { $sorted[0] }
+		elsif ( @sorted % 2 )  { $sorted[ int(@sorted / 2) ] }
+		else {
+			my $mid_high = int(@sorted/2);
+			($sorted[$mid_high-1] + $sorted[$mid_high])/2;
+		}
+	};
+
+	printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose;
+
+    return $median;
+}
+
 # Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
 sub _parse {
     my ($self, $file, $handle) = @_;
     my $output = $self->{mirrors};
-    my $geo = $self->{geography};
+    my $geo    = $self->{geography};
 
     local $/ = "\012";
     my $line = 0;
@@ -193,7 +440,7 @@ sub _parse {
             $mirror ||= {};
             if ( $prop eq 'dst_location' ) {
                 my (@location,$continent,$country);
-                @location = (split /\s*,\s*/, $value) 
+                @location = (split /\s*,\s*/, $value)
                     and ($continent, $country) = @location[-1,-2];
                 $continent =~ s/\s\(.*//;
                 $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
@@ -244,35 +491,61 @@ sub new {
     $arg ||= {};
     bless $arg, $self;
 }
-sub hostname { shift->{hostname} }
-sub continent { shift->{continent} }
-sub country { shift->{country} }
-sub http { shift->{http} || '' }
-sub ftp { shift->{ftp} || '' }
-sub rsync { shift->{rsync} || '' }
-
-sub url { 
+sub hostname  { shift->{hostname}    }
+sub continent { shift->{continent}   }
+sub country   { shift->{country}     }
+sub http      { shift->{http}  || '' }
+sub ftp       { shift->{ftp}   || '' }
+sub rsync     { shift->{rsync} || '' }
+sub rtt       { shift->{rtt}         }
+sub ping_time { shift->{ping_time}   }
+
+sub url {
     my $self = shift;
     return $self->{http} || $self->{ftp};
 }
 
 sub ping {
     my $self = shift;
+
     my $ping = Net::Ping->new("tcp",1);
     my ($proto) = $self->url =~ m{^([^:]+)};
     my $port = $proto eq 'http' ? 80 : 21;
     return unless $port;
-    if ( $ping->can('port_number') ) {
-    $ping->port_number($port);
+
+	if ( $ping->can('port_number') ) {
+        $ping->port_number($port);
     }
     else {
         $ping->{'port_num'} = $port;
     }
+
     $ping->hires(1) if $ping->can('hires');
     my ($alive,$rtt) = $ping->ping($self->hostname);
-    return $alive ? $rtt : undef;
+
+    $self->{rtt} = $alive ? $rtt : undef;
+    $self->{ping_time} = time;
+
+    $self->rtt;
 }
 
 
 1;
 
+=back
+
+=head1 AUTHOR
+
+Andreas Koenig C<< <andk@cpan.org> >>, David Golden C<< <dagolden@cpan.org> >>,
+brian d foy C<< <bdfoy@cpan.org> >>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+
+
+=cut