move tlperl.straw to tlperl

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

1 files changed, 260 insertions, 0 deletions

diff --git a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
new file mode 100755
index 00000000000..1a3402e8de5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
@@ -0,0 +1,260 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Mirrors;
+use strict;
+use vars qw($VERSION $urllist $silent);
+$VERSION = "1.77";
+
+use Carp;
+use FileHandle;
+use Fcntl ":flock";
+
+sub new {
+    my ($class, $file) = @_;
+    my $self = bless { 
+        mirrors => [], 
+        geography => {},
+    }, $class;
+
+    my $handle = FileHandle->new;
+    $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
+
+    return $self
+}
+
+sub continents {
+    my ($self) = @_;
+    return keys %{$self->{geography}};
+}
+
+sub countries {
+    my ($self, @continents) = @_;
+    @continents = $self->continents unless @continents;
+    my @countries;
+    for my $c (@continents) {
+        push @countries, keys %{ $self->{geography}{$c} };
+    }
+    return @countries;
+}
+
+sub mirrors {
+    my ($self, @countries) = @_;
+    return @{$self->{mirrors}} unless @countries;
+    my %wanted = map { $_ => 1 } @countries;
+    my @found;
+    for my $m (@{$self->{mirrors}}) {
+        push @found, $m if exists $wanted{$m->country};
+    }
+    return @found;
+}
+
+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 $seen = {};
+
+    if ( ! @$conts ) {
+        print "Searching for the best continent ...\n" if $verbose;
+        my @best = $self->_find_best_continent($seen, $verbose, $callback);
+
+        # how many continents to find enough mirrors? We should scan
+        # more than we need -- arbitrarily, we'll say x2
+        my $count = 0;
+        for my $c ( @best ) {
+            push @$conts, $c;
+            $count += $self->mirrors( $self->countries($c) );
+            last if $count >= 2 * $how_many;
+        }
+    }
+
+    print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose;
+
+    my @timings;
+    for my $m ($self->mirrors($self->countries(@$conts))) {
+        next unless $m->ftp;
+        my $hostname = $m->hostname;
+        if ( $seen->{$hostname}  ) {
+            push @timings, $seen->{$hostname}
+                if defined $seen->{$hostname}[1];
+        }
+        else {
+            my $ping = $m->ping;
+            next unless defined $ping;
+            push @timings, [$m, $ping];
+            $callback->($m,$ping) if $callback;
+        }
+    }
+    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];
+}
+
+sub _find_best_continent {
+    my ($self, $seen, $verbose, $callback) = @_;
+
+    my %median;
+    CONT: for my $c ( $self->continents ) {
+        my @mirrors = $self->mirrors( $self->countries($c) );
+        next CONT unless @mirrors;
+        my $sample = 9;
+        my $n = (@mirrors < $sample) ? @mirrors : $sample;
+        my @tests;
+        RANDOM: while ( @mirrors && @tests < $n ) {
+            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;
+        }
+    }
+
+    my @best_cont = sort { $median{$a} <=> $median{$b} } keys %median ;
+
+    if ( $verbose ) {
+        print "Median result by continent:\n";
+        for my $c ( @best_cont ) {
+            printf( "  %d ms  %s\n", int($median{$c}*1000+.5), $c );
+        }
+    }
+
+    return wantarray ? @best_cont : $best_cont[0];
+}
+
+# Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
+sub _parse {
+    my ($self, $file, $handle) = @_;
+    my $output = $self->{mirrors};
+    my $geo = $self->{geography};
+
+    local $/ = "\012";
+    my $line = 0;
+    my $mirror = undef;
+    while ( 1 ) {
+        # Next line
+        my $string = <$handle>;
+        last if ! defined $string;
+        $line = $line + 1;
+
+        # Remove the useless lines
+        chomp( $string );
+        next if $string =~ /^\s*$/;
+        next if $string =~ /^\s*#/;
+
+        # Hostname or property?
+        if ( $string =~ /^\s/ ) {
+            # Property
+            unless ( $string =~ /^\s+(\w+)\s+=\s+\"(.*)\"$/ ) {
+                croak("Invalid property on line $line");
+            }
+            my ($prop, $value) = ($1,$2);
+            $mirror ||= {};
+            if ( $prop eq 'dst_location' ) {
+                my (@location,$continent,$country);
+                @location = (split /\s*,\s*/, $value) 
+                    and ($continent, $country) = @location[-1,-2];
+                $continent =~ s/\s\(.*//;
+                $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
+                $geo->{$continent}{$country} = 1 if $continent && $country;
+                $mirror->{continent} = $continent || "unknown";
+                $mirror->{country} = $country || "unknown";
+            }
+            elsif ( $prop eq 'dst_http' ) {
+                $mirror->{http} = $value;
+            }
+            elsif ( $prop eq 'dst_ftp' ) {
+                $mirror->{ftp} = $value;
+            }
+            elsif ( $prop eq 'dst_rsync' ) {
+                $mirror->{rsync} = $value;
+            }
+            else {
+                $prop =~ s/^dst_//;
+                $mirror->{$prop} = $value;
+            }
+        } else {
+            # Hostname
+            unless ( $string =~ /^([\w\.-]+)\:\s*$/ ) {
+                croak("Invalid host name on line $line");
+            }
+            my $current = $mirror;
+            $mirror     = { hostname => "$1" };
+            if ( $current ) {
+                push @$output, CPAN::Mirrored::By->new($current);
+            }
+        }
+    }
+    if ( $mirror ) {
+        push @$output, CPAN::Mirrored::By->new($mirror);
+    }
+
+    return;
+}
+
+#--------------------------------------------------------------------------#
+
+package CPAN::Mirrored::By;
+use strict;
+use Net::Ping   ();
+
+sub new {
+    my($self,$arg) = @_;
+    $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 { 
+    my $self = shift;
+    return $self->{ftp} || $self->{http};
+}
+
+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;
+    $ping->port_number($port);
+    $ping->hires(1);
+    my ($alive,$rtt) = $ping->ping($self->hostname);
+    return $alive ? $rtt : undef;
+}
+
+
+1;
+