bin/mymirmon

   1 #!perl
   2
   3 use DateTime::Format::DateParse;
   4 use Getopt::Long;
   5 use LWP::UserAgent;
   6 use Parse::CPAN::MirroredBy;
   7 use File::Rsync;
   8 use File::Temp qw(tempdir);
   9
  10 my %Opt;
  11 GetOptions(\%Opt, "all|a!") or die;
  12
  13 my $ua = LWP::UserAgent->new( timeout => 12 );
  14 my $rsync = File::Rsync->new({ verbose => 1, timeout => 12 });
  15
  16 my @uri =
  17 (
  18  "http://cpan.cpantesters.org/",             # barbie
  19  "rsync://cpan.cpantesters.org/cpan/",       # barbie
  20  "http://cpan.solfo.com/",                   # abh
  21  "http://theoryx5.uwinnipeg.ca/pub/CPAN/",   # rkobes
  22  "http://cpan.hexten.net/",                  # andya
  23  "rsync://cpan.hexten.net/cpan/",            # andya
  24  "http://cpan.perl.pt/",                     # melo
  25  "http://cpan.dagolden.com/",                # dagolden
  26  "ftp://ftp.funet.fi/pub/languages/perl/CPAN/",
  27 );
  28
  29 if ($Opt{all}) {
  30     my $pcm = Parse::CPAN::MirroredBy->new;
  31     my @mirrors = $pcm->parse_file( '/home/k/sources/CPAN/ghub/cpanpm/MIRRORED.BY' );
  32     my $preferproto = "rsync";
  33     for my $mirror (@mirrors) {
  34         $DB::single++;
  35         # warn "mirror[$mirror]";
  36         if ($mirror->{dst_rsync} && $mirror->{dst_http}) {
  37             my $uri = $mirror->{"dst_$preferproto"};
  38             $uri =~ s|/?$|/|;
  39             if ($preferproto eq "rsync") {
  40                 $uri =~ s|^(rsync://)?|rsync://|;
  41                 $uri =~ s|::|/|;
  42             }
  43             push @uri, $uri;
  44         }
  45     }
  46 }
  47
  48 my $tmpdir = tempdir(CLEANUP => 1);
  49
  50 printf "%7s %-28s %s\n", "secs", "content of 02STAMP", "URL";
  51 printf "%7s %-28s %s\n", "-------", "--------------------------", "----";
  52 URI: for my $uri (@uri) {
  53     my $content;
  54     if ($uri =~ m|^rsync://|) {
  55         unless ($rsync->exec( { src => $uri . "authors/02STAMP", dest => "$tmpdir/02STAMP" } )) {
  56             warn sprintf "      rsync to '%s' failed: '%s'\n", $uri, $rsync->err;
  57             next URI;
  58         }
  59         $content = do { open my $fh, "$tmpdir/02STAMP" or die; local $/; <$fh> };
  60     } elsif ($uri =~ m!^(?:http|ftp)://!) {
  61         my $resp = $ua->get($uri . "authors/02STAMP");
  62         if ($resp->is_success) {
  63             $content = $resp->content;
  64         } else {
  65             warn sprintf "      Could not reach '%s': %s\n", $uri, $resp->message;
  66             next URI;
  67         }
  68     } else {
  69         die "Illegal protocol in '$uri'";
  70     }
  71     chomp $content;
  72     my $dt = DateTime::Format::DateParse->parse_datetime( $content );
  73     my $now = DateTime->now;
  74     my $diff = $now->epoch - $dt->epoch;
  75     printf "%7d %s %s\n", $diff, $content, $uri;
  76 }
  77
  78 print q{Maybe try on PAUSE
  79     perl -MYAML::Syck -nle '/\(([a-z]\w+)\)/ && $S{$1}++; END { print YAML::Syck::Dump \%S }' /var/log/rsyncd2
  80 };