mirmon/mirmon

   1 #!/usr/bin/perl -w
   2 # $Cambridge$
   3 # Copyright (c) 2003 Henk Penning, all rights reserved.
   4 # penning@cs.uu.nl, http://www.cs.uu.nl/staff/henkp.html
   5 # Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28
   6 # $Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $
   7 # Permission is hereby granted, free of charge, to any person obtaining a
   8 # copy of this software and associated documentation files (the "Software"),
   9 # to deal in the Software without restriction, including without limitation
  10 # the rights to use, copy, modify, merge, publish, distribute, sublicense,
  11 # and/or sell copies of the Software, and to permit persons to whom the
  12 # Software is furnished to do so, subject to the following conditions:
  13 #
  14 # The above copyright notice and this permission notice shall be included in
  15 # all copies or substantial portions of the Software.
  16 #
  17 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  18 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  19 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  20 # THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  21 # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  22 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  23 # DEALINGS IN THE SOFTWARE.
  24 #
  25 # Thanks to Klaus Heinz <heinz@NetBSD.org> for sugestions ao htm_head
  26 my $PRG = 'mirmon';
  27 my $VER = '$Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $';
  28 use strict;
  29 use IO::Pipe;
  30 use IO::Select;
  31 use Net::hostent;
  32 my $DEF_CNF = "/etc/$PRG.conf";
  33 my %CNF = qw( timeout    300
  34   max_probes 25
  35   min_poll   1h
  36   max_poll   4h
  37   min_sync   1d
  38   max_sync   2d
  39   list_style plain
  40   put_histo  top
  41   randomize  1
  42 );
  43 my @REQ_KEYS = qw( web_page state countries mirror_list probe
  44   project_name project_url icons
  45 );
  46 my @OPT_KEYS =
  47   qw( project_logo min_poll min_sync max_sync list_style htm_top htm_foot
  48   htm_head put_histo
  49 );
  50 my %CNF_KEYS;
  51 for ( @REQ_KEYS, @OPT_KEYS, keys %CNF ) { $CNF_KEYS{$_}++; }
  52 my $TIM_PAT    = '^(\d+)([smhd])$';
  53 my @LIST_STYLE = qw(plain apache);
  54 my @GET_OPTS   = qw(all update);
  55 my @PUT_HGRAM  = qw(top bottom nowhere);
  56 my $HIST       = 14;
  57 my %APA_TYPES  = ();
  58 for (qw(backup ftp http)) { $APA_TYPES{$_}++; }
  59 my $prog = substr( $0, rindex( $0, '/' ) + 1 );
  60 my $Usage = <<USAGE ;
  61 Usage: $prog [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
  62 option v   : be verbose
  63 option q   : be quiet
  64 option t   : set timeout [ default $CNF{timeout} ] ;
  65 option get : 'all'    : probe all sites
  66            : 'update' : probe a selection of the sites (see doc)
  67 option c   : configuration file [ default $DEF_CNF ]
  68 -------------------------------------------------------------------
  69 Documentation : the program contains 'pod' style documentation.
  70 Extract the doc with 'pod2text $prog' or 'pod2html $prog OUT', etc.
  71 -------------------------------------------------------------------
  72 USAGE
  73 sub Usage { die "$_[0]$Usage"; }
  74 sub Error { die "$prog: $_[0]\n"; }
  75 sub Warn  { warn "$prog: $_[0]\n"; }
  76 # usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
  77 # usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
  78 # ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
  79 # ID  = perl identifier
  80 # SPC = i|f|s for integer, fixedpoint real or string argument
  81 use Getopt::Long;
  82 Getopt::Long::config('no_ignore_case');
  83 # Usage() unless GetOptions() ;
  84 my %opt = ();
  85 Usage() unless GetOptions( \%opt, 'v', 'q', 't=i', 'get=s', 'c=s' );
  86 Usage("Arg count\n") unless @ARGV >= 0;
  87 my %WGT;
  88 my $GET = IO::Select->new();
  89 my %URL;
  90 my %RES;
  91 my %OLD;
  92 my %LST;
  93 my %CCS;
  94 my %HREF;
  95 # <META HTTP-EQUIV=Expires CONTENT="Tue, 04 Dec 1993 21:29:02 GMT">
  96 sub exp_date {
  97     my @day = qw(Sun Mon Tue Wed Thu Fri Sat);
  98     my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  99     my @gmt = gmtime time + 3600;
 100     sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT", $day[ $gmt[6] ], $gmt[3],
 101       $mon[ $gmt[4] ], $gmt[5] + 1900, @gmt[ 2, 1, 0 ];
 102 }
 103 sub find_conf {
 104     return $opt{c} if $opt{c};
 105     my $HOME = ( getpwuid $< )[7] or Error "can get homedir '$<' ($!)";
 106     my @LIST = ( "$PRG.conf", "$HOME/.$PRG.conf", $DEF_CNF );
 107     for my $conf (@LIST) { return $conf if -f $conf; }
 108     Error sprintf "can't find a config file :\n  %s", join "\n  ", @LIST;
 109 }
 110 sub show_conf {
 111     print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n";
 112     for my $key ( sort keys %CNF ) {
 113         next if $key =~ m/^_/;
 114         print "show_conf : $key = '$CNF{$key}'\n";
 115     }
 116     for my $key ( sort keys %HREF ) {
 117         printf "show_conf : for site '%s' use instead\n   '%s'\n", $key,
 118           $HREF{$key}
 119           if $opt{v};
 120     }
 121     printf "show_conf : included '%s'\n", join "', '", @{ $CNF{_include} };
 122     print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n";
 123 }
 124 sub get_conf;
 125 sub get_conf {
 126     my $FILE = shift;
 127     if ( grep $_ eq $FILE, @{ $CNF{_include} } ) {
 128         Error "already included : '$FILE'";
 129     }
 130     else { push @{ $CNF{_include} }, $FILE; }
 131     open FILE, $FILE or Error "can't open '$FILE' ($!)";
 132     my $CONF = join "\n", grep /./, <FILE>;
 133     close FILE;
 134     $CONF =~ s/\t/ /g;          # replace tabs
 135     $CONF =~ s/^[+ ]+//;        # delete leading space, plus
 136     $CONF =~ s/\n\n\s+/ /g;     # glue continuation lines
 137     $CONF =~ s/\n\n\+\s+//g;    # glue concatenation lines
 138     $CONF =~ s/\n\n\./\n/g;     # glue concatenation lines
 139     chop $CONF;
 140     print "--$CONF--\n" if $opt{d};
 141     for ( grep !/^#/, split /\n\n/, $CONF ) {
 142         my ( $key, $val ) = split ' ', $_, 2;
 143         $val = '' unless defined $val;
 144         print "conf '$FILE' : key '$key', val '$val'\n" if $opt{d};
 145         if ( exists $CNF_KEYS{$key} ) { $CNF{$key} = $val; }
 146         elsif ( $key eq 'site_url' ) {
 147             my ( $site, $url ) = split ' ', $val;
 148             $url .= '/' unless $url =~ m!/$!;
 149             $HREF{ lc $site } = $url;
 150             printf "config : for site '%s' use instead\n   '%s'\n", $site, $url
 151               if $opt{v};
 152         }
 153         elsif ( $key eq 'env' ) {
 154             my ( $x, $y ) = split ' ', $val;
 155             $ENV{$x} = $y;
 156             printf "config : setenv '%s'\n   '%s'\n", $x, $y if $opt{v};
 157         }
 158         elsif ( $key eq 'no_randomize' ) { $CNF{randomize} = 0; }
 159         elsif ( $key eq 'include' ) { get_conf $val ; }
 160         elsif ( $key eq 'show' )    { show_conf unless $opt{q}; }
 161         elsif ( $key eq 'exit' )    { Error 'exit per config directive'; }
 162         elsif ( $key eq 'max_age' ) { $CNF{max_sync} = $val; }
 163         else {
 164             show_conf;
 165             Error "unknown keyword '$key' (value '$val')";
 166         }
 167     }
 168 }
 169 sub get_conf_opt {
 170     my $err = '';
 171     get_conf find_conf;
 172     $CNF{timeout} = $opt{t} if $opt{t};
 173     for my $key (@REQ_KEYS) {
 174         unless ( exists $CNF{$key} ) {
 175             $err .= "$prog error: missing config for '$key'\n";
 176         }
 177     }
 178     for my $key (qw(min_poll max_poll max_sync min_sync)) {
 179         my $max = $CNF{$key};
 180         unless ( $max =~ /$TIM_PAT/o ) {
 181             $err .= "$prog error: $key ($max) doesn't match /$TIM_PAT/\n";
 182         }
 183     }
 184     unless ( grep $CNF{list_style} eq $_, @LIST_STYLE ) {
 185         $err .= sprintf "%s : error: unknown 'list_style' '%s'\n", $prog,
 186           $CNF{list_style};
 187     }
 188     unless ( grep $CNF{put_histo} eq $_, @PUT_HGRAM ) {
 189         $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n", $prog,
 190           $CNF{put_histo};
 191     }
 192     if ( $opt{get} and not grep $opt{get} eq $_, @GET_OPTS ) {
 193         $err .= sprintf "%s : error: unknown 'get option' '%s'\n", $prog,
 194           $opt{get};
 195     }
 196     Error $err if $err;
 197     $opt{q} = 0 if $opt{v};
 198 }
 199 sub tim_to_s {
 200     my $tim = shift;
 201     my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 );
 202     Error "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o;
 203     my $m = $1;
 204     my $u = $2;
 205     return $m * $tab{$u};
 206 }
 207 sub aprx_eq { my ( $t1, $t2 ) = @_; abs( $t1 - $t2 ) < 60; }
 208 sub aprx_ge { my ( $t1, $t2 ) = @_; $t1 > $t2 or aprx_eq $t1, $t2; }
 209 sub aprx_le { my ( $t1, $t2 ) = @_; $t1 < $t2 or aprx_eq $t1, $t2; }
 210 sub aprx_gt { my ( $t1, $t2 ) = @_; $t1 > $t2 and not aprx_eq $t1, $t2; }
 211 sub aprx_lt { my ( $t1, $t2 ) = @_; $t1 < $t2 and not aprx_eq $t1, $t2; }
 212 sub pr_interval {
 213     my $s = shift;
 214     my ( $magn, $unit );
 215     my $mins  = $s / 60;
 216     my $m     = int( $mins + 0.5 );
 217     my $hours = $s / ( 60 * 60 );
 218     my $h     = int( $hours + 0.5 );
 219     if    ( $s < 50 ) { $magn = $s; $unit = 'second'; }
 220     elsif ( $m < 50 ) { $magn = $m; $unit = 'minute'; }
 221     elsif ( $h < 36 ) { $magn = $h; $unit = 'hour'; }
 222     else              { $magn = sprintf "%.1f", $hours / 24; $unit = 'day'; }
 223     $unit .= 's' unless $magn == 1;
 224     return "$magn $unit";
 225 }
 226 sub max_age1 {
 227     ( tim_to_s $CNF {min_sync} ) + ( tim_to_s $CNF {max_poll} );
 228 }
 229 sub max_age2 {
 230     ( tim_to_s $CNF {max_sync} ) + ( tim_to_s $CNF {max_poll} );
 231 }
 232 sub max_vrfy {
 233     ( tim_to_s $CNF {min_poll} ) + ( tim_to_s $CNF {max_poll} );
 234 }
 235 sub age_code {
 236     my $time = shift;
 237     return 'z' unless $time =~ /^\d+$/;
 238     return (
 239         ( aprx_ge( $time, $^T - max_age1 ) )
 240         ? 's'
 241         : ( aprx_ge( $time, $^T - max_age2 ) ? 'b' : 'f' )
 242     );
 243 }
 244 sub err {
 245     my $url  = shift;
 246     my $stat = shift;
 247     printf "*** %-10s %s\n", $stat, $url unless $opt{q};
 248     my ( $time, $vrfy, $hstp, $hsts );
 249     if ( exists $OLD{$url} ) {
 250         $time = $OLD{$url}[0];
 251         $vrfy = $OLD{$url}[2];
 252         $hstp = substr $OLD{$url}[3], 1 - $HIST;
 253         $hsts = $OLD{$url}[4];
 254     }
 255     else {
 256         $time = 'undef';
 257         $vrfy = 'undef';
 258         $hstp = '';
 259         $hsts = '';
 260     }
 261     $RES{$url} = [ $time, $stat, $vrfy, $hstp . 'f', $hsts, $^T ];
 262 }
 263 sub res {
 264     my $url  = shift;
 265     my $time = shift;
 266     my $stat = shift;
 267     my $hstp = (
 268         exists $OLD{$url}
 269         ? substr( $OLD{$url}[3], 1 - $HIST )
 270         : ''
 271     );
 272     my $hsts = ( exists $OLD{$url} ? $OLD{$url}[4] : '' );
 273     printf "result %d %s\n", $time, $url if $opt{v};
 274     $RES{$url} = [ $time, $stat, $^T, $hstp . 's', $hsts, $^T ];
 275 }
 276 sub get_state {
 277     my $STT = shift;
 278     open STT, $STT or Error "can't open '$STT' ($!)";
 279     while (<STT>) {
 280         chop;
 281         my ( $url, $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = split ' ';
 282         $stat =~ s/_/ /g;
 283         $hstp = '' unless defined $hstp;
 284         $hsts = '' unless defined $hsts;
 285         $hsts = '' if $hsts eq 'undef';
 286         $lprb = 'undef' unless defined $lprb;
 287         $OLD{$url} = [ $time, $stat, $vrfy, $hstp, $hsts, $lprb ];
 288     }
 289     close STT;
 290 }
 291 sub check_hist {
 292     my $time = shift;
 293     my $hsts = shift;
 294     printf "check_hist: last '$time' hsts '$hsts'\n" if $opt{d};
 295     my $res = $hsts;
 296     my ( $stmp, $hist );
 297     if ( $hsts eq '' ) { $stmp = 0; $hist = ''; }
 298     else               { ( $stmp, $hist ) = split '-', $hsts; }
 299     if ( aprx_le $stmp, $^T - tim_to_s '1d' ) {
 300         $res = sprintf "%s-%s%s", $^T, substr( $hist, 1 - $HIST ),
 301           age_code($time);
 302     }
 303     return $res;
 304 }
 305 sub put_state {
 306     my $STT = shift;
 307     my $TMP = "$STT.tmp";
 308     open TMP, ">$TMP" or Error "can't write '$TMP' ($!)";
 309     for my $url ( sort keys %RES ) {
 310         $RES{$url}[4] = check_hist $RES {$url}[0], $RES{$url}[4];
 311         my @OUT = @{ $RES{$url} };
 312         $OUT[1] =~ s/\s/_/g;
 313         printf TMP "%s %s\n", $url, join ' ', @OUT
 314           or Error "can't print to $TMP ($!)";
 315     }
 316     close TMP;
 317     if ( -z $TMP ) { Warn "wrote empty state file; keeping previous version"; }
 318     else { rename $TMP, $STT or Error "can't rename '$TMP', '$STT' ($!)"; }
 319 }
 320 sub get_ccs {
 321     my $CCS = shift;
 322     open CCS, $CCS or Error "can't open '$CCS' ($!)";
 323     while (<CCS>) {
 324         chop;
 325         next if /^#/;
 326         my ( $code, $dash, $reg ) = split ' ', $_, 3;
 327         $CCS{ lc $code } = lc $reg;
 328     }
 329     close CCS;
 330 }
 331 sub type_site {
 332     my $url = shift;
 333     my ( $type, $site, $home );
 334     if ( $url =~ m!^(ftp|http)://([^/:]+)(:\d+)?/! ) {
 335         $type = $1;
 336         $site = $2;
 337         $home = $&;
 338     }
 339     return $type, $site, $home;
 340 }
 341 sub type { my ( $t, $s, $h ) = type_site $_[0]; $t; }
 342 sub site { my ( $t, $s, $h ) = type_site $_[0]; $s; }
 343 sub home { my ( $t, $s, $h ) = type_site $_[0]; $h; }
 344 sub get_list {
 345     my $LST = shift;
 346     my ( $reg, $url );
 347     open LST, $LST or Error "can't open '$LST' ($!)";
 348     while (<LST>) {
 349         chop;
 350         next if /^#/;
 351         next if /^\s*$/;
 352         if ( $CNF{list_style} eq 'plain' ) {
 353             ( $reg, $url ) = split ' ';
 354             unless ( $url =~ m!/$! ) {
 355                 print "*** mirmon appended '/' to $url\n" unless $opt{q};
 356                 $url .= '/';
 357             }
 358         }
 359         elsif ( $CNF{list_style} eq 'apache' ) {
 360             my $apache_type;
 361             ( $apache_type, $reg, $url ) = split ' ';
 362             unless ( defined $APA_TYPES{$apache_type} ) {
 363                 print "*** strange type : $apache_type\n" unless $opt{q};
 364                 next;
 365             }
 366             unless ( $url =~ m!/$! ) {
 367                 print "*** missing '/' in $url\n" unless $opt{q};
 368                 $url .= '/';
 369             }
 370         }
 371         my $site = site $url ;
 372         my $type = type $url ;
 373         unless ( defined $site ) {
 374             print "*** strange url : '$url'\n" unless $opt{q};
 375             next;
 376         }
 377         $LST{$url} = [ $type, $site, $reg ];
 378     }
 379 }
 380 sub url { sprintf '<A HREF="%s">%s</A>', $_[0], $_[1]; }
 381 sub nam { sprintf '<A NAME="%s">%s</A>', $_[0], $_[1]; }
 382 sub SMA { sprintf "<FONT SIZE=\"-1\">%s</FONT>", $_[0]; }
 383 sub BLD { sprintf "<B>%s</B>", $_[0]; }
 384 sub NSS { sprintf SMA('%s&nbsp;site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ); }
 385 sub TAB { sprintf "<TABLE BORDER=2 CELLPADDING=3>%s</TABLE>", $_[0]; }
 386 sub TR  { sprintf "<TR>%s</TR>\n",                            $_[0]; }
 387 sub TH  { sprintf "<TH>%s</TH>\n",                            $_[0]; }
 388 sub TD  { sprintf "<TD>%s</TD>\n",                            $_[0]; }
 389 sub TDr { sprintf "<TD ALIGN=\"RIGHT\">%s</TD>\n",            $_[0]; }
 390 sub RED { sprintf "<FONT COLOR=\"RED\">%s</FONT>",            $_[0]; }
 391 sub GRN { sprintf '<FONT COLOR="GREEN">%s</FONT>',            $_[0]; }
 392 sub htmlquote {
 393     my $x = shift;
 394     $x =~ s/&/&amp;/g;
 395     $x =~ s/</&lt;/g;
 396     $x =~ s/>/&gt;/g;
 397     return $x;
 398 }
 399 sub diff {
 400     my $time = shift;
 401     my $max  = shift;
 402     my $res;
 403     if ( $time == $^T ) { $res = BLD 'renewed'; }
 404     else {
 405         $res = pr_interval $^T - $time;
 406         $res = BLD RED $res if aprx_lt $time, $max;
 407     }
 408     return $res;
 409 }
 410 sub img_sf_cnt {
 411     sprintf '<IMG BORDER=1 SRC="%s/mm%s%02d.gif" ALT="">', $CNF{icons}, $_[0],
 412       $_[1];
 413 }
 414 sub img_sf { img_sf_cnt $_[0], 1; }
 415 sub show_hist {
 416     my $hst = shift;
 417     return '' unless $hst =~ m/^[sbfz]+$/;
 418     if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ ) {
 419         return img_sf_cnt 'sb', length $1;
 420     }
 421     elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ ) {
 422         return img_sf_cnt 'sf', length $1;
 423     }
 424     elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ ) {
 425         return img_sf_cnt 'sbf', length $1;
 426     }
 427     my $res = '';
 428     my $cnt = 1;
 429     my $prf = substr $hst, 0, 1;
 430     $hst = substr $hst, 1;
 431     while ( $hst ne '' ) {
 432         if ( substr( $prf, 0, 1 ) eq substr( $hst, 0, 1 ) ) {
 433             $cnt++;
 434             $hst = substr $hst, 1;
 435         }
 436         else {
 437             $res .= img_sf_cnt $prf, $cnt;
 438             $prf = substr $hst, 0, 1;
 439             $hst = substr $hst, 1;
 440             $cnt = 1;
 441         }
 442     }
 443     $res .= img_sf_cnt $prf, $cnt if $cnt;
 444     return $res;
 445 }
 446 sub show_hist_age {
 447     my $hsts = shift;
 448     my $time = shift;
 449     return '' if $hsts eq '';
 450     my ( $t, $h ) = split '-', $hsts;
 451     if ( aprx_lt $t, $^T ) { $h .= age_code $time ; }
 452     return show_hist substr $h, -$HIST;
 453 }
 454 sub gen_histogram_probes {
 455     my ( $time, $stat, $vrfy, $hstp, $hsts, $lprb );
 456     my %tab   = ();
 457     my %bad   = ();
 458     my $res   = '';
 459     my $s_cnt = 0;
 460     my $f_cnt = 0;
 461     my $hr_min;
 462     my $hr_max;
 463     return '' unless scalar keys %RES;
 464     for my $url ( keys %RES ) {
 465         ( $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = @{ $RES{$url} };
 466         my $hr = int( ( $^T - $lprb ) / 3600 + 0.5 );
 467         $hr_min = $hr if !defined $hr_min or $hr < $hr_min;
 468         $hr_max = $hr if !defined $hr_max or $hr > $hr_max;
 469         if   ( $stat eq 'ok' ) { $tab{$hr}++; $s_cnt++; }
 470         else                   { $bad{$hr}++; $f_cnt++; }
 471     }
 472     $res = TR(
 473             TH('hours ago')
 474           . TH('succ')
 475           . TH('fail')
 476           . TH sprintf( '%s %s, %s %s',
 477             $s_cnt, GRN('successful'), $f_cnt, RED('failed') )
 478     );
 479     my $max = 0;
 480     for my $x ( keys %tab ) {
 481         my $tot = $tab{$x} + ( $bad{$x} || 0 );
 482         $max = $tot if $max < $tot;
 483     }
 484     return "<BLOCKQUOTE>\nnothing yet\n</BLOCKQUOTE>\n" unless $max;
 485     for my $hr ( $hr_min .. $hr_max ) {
 486         my $x = $tab{$hr} || 0;
 487         my $y = $bad{$hr} || 0;
 488         my $n = int( $x / $max * $HIST );
 489         my $b = int( $y / $max * $HIST );
 490         $res .= TR(
 491                 TDr($hr)
 492               . TDr($x)
 493               . TDr($y)
 494               . TD(
 495                   ( $n ? img_sf_cnt( 's', $n ) : '' )
 496                 . ( $b ? img_sf_cnt( 'f', $b ) : '' )
 497                   . ( ( $n + $b ) ? '' : '&nbsp;' )
 498               )
 499         );
 500     }
 501     return "<BLOCKQUOTE>\n" . TAB($res) . "</BLOCKQUOTE>\n";
 502 }
 503 sub gen_histogram {
 504     my $MAX_H = max_age1;
 505     my $MAX_h = 1 + (
 506         ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 )
 507         ? int( $MAX_H / 3600 )
 508         : 25
 509     );
 510     my $MAX_O = max_age2;
 511     my $MAX_o = int( $MAX_O / 3600 + 0.5 );
 512     my $H     = 18;
 513     my %W     = ( 'old' => 1, 'ded' => 1, 'bad' => 1 );
 514     my %Wmx   = ( 'old' => 5, 'ded' => 3, 'bad' => 3 );
 515     my %tab;
 516     my %hst;
 517     my $res;
 518     for ( my $x = 0 ; $x < $MAX_h ; $x++ ) { $tab{$x} = 0; }
 519     $tab{old} = 0;
 520     $tab{ded} = 0;
 521     $tab{bad} = 0;
 522     for my $url ( keys %RES ) {
 523         my $time = $RES{$url}[0];
 524         if ( $time =~ /^\d+$/ ) {
 525             my $s = $^T - $time;
 526             my $hr = int( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 );
 527             if    ( $s <= $MAX_H ) { $tab{$hr}++; }
 528             elsif ( $s <= $MAX_O ) { $tab{old}++; }
 529             else                   { $tab{ded}++; }
 530         }
 531         else { $tab{bad}++; }
 532     }
 533     my $max = 0;
 534     for ( grep !exists $Wmx{$_}, keys %tab ) {
 535         $max = $tab{$_} if $tab{$_} > $max;
 536     }
 537     my %bad;
 538     for my $aux ( keys %Wmx ) {
 539         $bad{$aux} = $tab{$aux};
 540         if ( $bad{$aux} > $max ) {
 541             $W{$aux} = $Wmx{$aux};
 542             my $d = int( $bad{$aux} / $W{$aux} );
 543             for ( my $i = 1 ; $i < $W{$aux} ; $i++ ) {
 544                 $tab{ $aux . $i } = $d;
 545                 if ( $bad{$aux} % $Wmx{$aux} > $i ) {
 546                     $tab{ $aux . $i }++;
 547                     $tab{$aux}--;
 548                 }
 549             }
 550             $tab{$aux} -= ( $W{$aux} - 1 ) * $d;
 551             $max = $tab{$aux} if $max < $tab{$aux};
 552         }
 553     }
 554     #   if ( $opt{v} )
 555     #     { for my $hr ( keys %tab )
 556     #         { printf "tab '%s' = '%s'\n", $hr, $tab { $hr } ; }
 557     #     }
 558     return 'nothing yet' unless $max;
 559     $H = $max if 8 <= $max and $max <= 26;
 560     for ( keys %tab ) { $hst{$_} = int( $H * $tab{$_} / $max + 0.5 ); }
 561     my @keys = sort { $a <=> $b } grep /^\d+$/, keys %hst;
 562     my $tab_hr = 0;
 563     for my $hr (@keys) { $tab_hr += $tab{$hr}; }
 564     push @keys, grep ( m/^old/, sort keys %tab ),
 565       grep ( m/^ded/, sort keys %tab ), grep ( m/^bad/, sort keys %tab );
 566     for ( my $h = $H ; $h > 0 ; $h-- ) {
 567         $res .= "<TR>\n";
 568         $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"TOP\">&uarr;</TH>\n"
 569           if $h == $H;
 570         $res .= sprintf '<TD ROWSPAN=%d ALIGN="CENTER">%s</TD>' . "\n", $H - 6,
 571           NSS($max)
 572           if $h == $H - 3;
 573         $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"BOTTOM\">&darr;</TH>\n"
 574           if $h == 3;
 575         for my $x (@keys) {
 576             $res .= sprintf "<TH>%s</TH>\n",
 577               (
 578                 ( $hst{$x} >= $h )
 579                 ? img_sf(
 580                     $x =~ /^\d+$/
 581                     ? 's'
 582                     : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) )
 583                   )
 584                 : (
 585                     ( $h == 1 and $hst{$x} == 0 )
 586                     ? sprintf( '<IMG SRC="%s/bar.gif" ALT="" BORDER=0>',
 587                         $CNF{icons} )
 588                     : ''
 589                 )
 590               );
 591         }
 592         $res .= "</TR>\n";
 593     }
 594     my $HR = '<HR SIZE=2 WIDTH="95%%" NOSHADE>';
 595     $res .= "<TR>\n";
 596     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", 1;
 597     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $MAX_h;
 598     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W{old};
 599     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W{ded};
 600     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W{bad};
 601     $res .= "</TR>\n";
 602     $res .= "<TR>\n";
 603     $res .= '<TD ALIGN="CENTER">&nbsp;<B>age</B>&nbsp;&rarr;&nbsp;</TD>';
 604     $res .= "<TH>|</TH>\n";
 605     $res .=
 606       sprintf( '<TD COLSPAN=%d ALIGN="CENTER">'
 607           . '&larr;&nbsp; 0 &le; <B>age</B> &le; %s &nbsp;&rarr;'
 608           . "</TD>\n",
 609         $MAX_h - 2, pr_interval($MAX_H) );
 610     $res .= "<TH>|</TH>\n";
 611     $res .= sprintf(
 612         '<TD ALIGN="CENTER" COLSPAN=%d>'
 613           . '&nbsp;%sh&nbsp;&lt;&nbsp;%s&nbsp;&le;&nbsp;%sh&nbsp;'
 614           . "</TD>\n",
 615         $W{old}, int( $MAX_H / 60 / 60 ),
 616         BLD('age'), $MAX_o
 617     );
 618     $res .= sprintf(
 619         '<TD ALIGN="CENTER" COLSPAN=%d>'
 620           . '&nbsp;<FONT COLOR="RED">old</FONT>&nbsp;'
 621           . "</TD>\n",
 622         $W{ded}
 623     );
 624     $res .= sprintf(
 625         '<TD ALIGN="CENTER" COLSPAN=%d>'
 626           . '&nbsp;<FONT COLOR="RED">bad</FONT>&nbsp;'
 627           . "</TD>\n",
 628         $W{bad}
 629     );
 630     $res .= "</TR>\n";
 631     my $FRMT = '<TD ALIGN="CENTER" COLSPAN=%d>&nbsp;%s&nbsp;</TD>';
 632     $res .= "<TR>\n";
 633     $res .= sprintf "$FRMT\n", 1, NSS scalar keys %RES;
 634     $res .= "<TH>|</TH>\n";
 635     $res .= sprintf "$FRMT\n", $MAX_h - 2, NSS $tab_hr ;
 636     $res .= "<TH>|</TH>\n";
 637     $res .= sprintf "$FRMT\n", $W{old}, NSS $bad {old};
 638     $res .= sprintf "$FRMT\n", $W{ded}, NSS $bad {ded};
 639     $res .= sprintf "$FRMT\n", $W{bad}, NSS $bad {bad};
 640     $res .= "</TR>\n";
 641     $res = "<TABLE CELLSPACING=0 CELLPADDING=1 BORDER=0>\n$res\n</TABLE>\n";
 642     $res = sprintf "<TABLE CELLPADDING=5 BORDER=4>%s</TABLE>\n",
 643       "<TR><TH>\n$res\n</TH></TR>";
 644     if ( $max == $H ) {
 645         $res .= sprintf "<BR>units %s %s %s %s represent one mirror site.\n",
 646           img_sf('s'), img_sf('f'), img_sf('b'), img_sf('z');
 647     }
 648     else {
 649         $res .=
 650           sprintf "<BR>each %s %s %s %s unit represents %s mirror sites.\n",
 651           img_sf('s'), img_sf('f'), img_sf('b'), img_sf('z'),
 652           sprintf( "%.1f", $max / $H );
 653     }
 654     return $res;
 655 }
 656 sub revdom { my $dom = shift; join '.', reverse split /\./, $dom; }
 657 sub by_type_site {
 658     my $a_type = $a->[0];
 659     my $b_type = $b->[0];
 660     my $a_site = $a->[2];
 661     my $b_site = $b->[2];
 662     ( revdom $a_site ) cmp( revdom $b_site )
 663       or $a_type cmp $b_type;
 664 }
 665 sub by_CCS { ( $CCS{$a} || $a ) cmp( $CCS{$b} || $b ); }
 666 sub legend;
 667 sub gen_page {
 668     my $PPP = shift;
 669     my $TMP = "$PPP.tmp";
 670     my %tab;
 671     my $refs;
 672     for my $url ( keys %LST ) {
 673         my ( $type, $site, $reg ) = @{ $LST{$url} };
 674         push @{ $tab{$reg} }, [ $type, $url, $site ];
 675     }
 676     my $bad = 0;
 677     my $old = 0;
 678     my $unr = 0;
 679     my %stats;
 680     my @stats;
 681     my $ok = 0;
 682     for my $url ( keys %RES ) {
 683         my ( $time, $stat, $vrfy ) = @{ $RES{$url} };
 684         if   ( $stat eq 'ok' ) { $ok++; }
 685         else                   { $stats{$stat}++; }
 686         if    ( $time eq 'undef' )        { $bad++; }
 687         elsif ( 'f'   eq age_code $time ) { $old++; }
 688         if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - max_vrfy ) { $unr++; }
 689     }
 690     my $STAT =
 691       sprintf "%d bad -- %d older than %s -- %s unreachable for more than %s",
 692       $bad, $old, pr_interval(max_age2), $unr, pr_interval(max_vrfy);
 693     my $PROB = 'last probes : ';
 694     push @stats, "$ok were ok" if $ok;
 695     for my $stat ( sort keys %stats ) {
 696         push @stats, sprintf "%s had %s", $stats{$stat}, RED $stat ;
 697     }
 698     $PROB .= join ', ', @stats;
 699     for my $reg ( sort keys %tab ) {
 700         $refs .= sprintf "&nbsp;%s&nbsp;\n", url "#$reg",
 701           "<FONT SIZE=\"+1\">$reg</FONT>";
 702     }
 703     my $COLS = 5;
 704     my $LOGO =
 705       $CNF{project_logo}
 706       ? url(
 707         $CNF{project_url},
 708         sprintf(
 709             '<IMG SRC="%s" ALT="%s" ALIGN="RIGHT" BORDER=0>',
 710             $CNF{project_logo}, $CNF{project_name}
 711         )
 712       )
 713       : '';
 714     my $HTOP = $CNF{htm_top}  ? $CNF{htm_top} . "\n"  : '';
 715     my $FOOT = $CNF{htm_foot} ? $CNF{htm_foot} . "\n" : '';
 716     my $HEAD = $CNF{htm_head} ? $CNF{htm_head} . "\n" : '';
 717     my $TITL = url $CNF{project_url}, $CNF{project_name};
 718     my $EXPD = exp_date;
 719     open PPP, ">$TMP" or Error "can't write $TMP ($!)";
 720     print PPP '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01'
 721       . ' Transitional//EN"' . '>';
 722     print PPP "<HTML>\n";
 723     print PPP "<HEAD>\n";
 724     print PPP "<TITLE>the status of $CNF{project_name} mirrors</TITLE>\n";
 725     printf PPP "%s\n", '<meta HTTP-EQUIV="content-type" '
 726       . 'CONTENT="text/html; charset=ISO-8859-1">';
 727     print PPP "<META HTTP-EQUIV=\"refresh\" CONTENT=\"3600\">\n";
 728     print PPP "<META HTTP-EQUIV=\"Expires\" CONTENT=\"$EXPD\">\n";
 729     print PPP $HEAD if $HEAD;
 730     print PPP "</HEAD>\n";
 731     print PPP "<BODY BGCOLOR=\"#FFFFFF\">\n";
 732     print PPP $LOGO;
 733     print PPP "<H2>the status of $TITL mirrors</H2>\n";
 734     print PPP "<TABLE BORDER=0 CELLPADDING=2>\n";
 735     printf PPP "<TR><TD>date</TD><TD>:</TD><TD>%s (GMT)</TD></TR>\n",
 736       scalar gmtime $^T;
 737     printf PPP "<TR><TD>last&nbsp;check</TD><TD>:</TD><TD>%s (GMT)</TD></TR>\n",
 738       scalar gmtime( $opt{get} ? $^T : ( stat $CNF{state} )[9] );
 739     print PPP "</TABLE>\n";
 740     printf PPP "<P>%s</P>\n", $HTOP if $HTOP;
 741     if ( $CNF{put_histo} eq 'top' ) {
 742         print PPP "<H2>age histogram</H2>\n";
 743         print PPP "<BLOCKQUOTE>\n";
 744         print PPP gen_histogram;
 745         print PPP "</BLOCKQUOTE>\n";
 746     }
 747     print PPP "<H2>regions</H2>\n";
 748     print PPP "<BLOCKQUOTE>\n";
 749     print PPP "<CENTER>\n";
 750     printf PPP "%s\n", $refs;
 751     print PPP "</CENTER>\n";
 752     print PPP "</BLOCKQUOTE>\n";
 753     print PPP "<H2>report</H2>\n";
 754     my $attr1 = "COLSPAN=$COLS BGCOLOR=\"LIME\"";
 755     my $attr2 = 'BGCOLOR="AQUA"';
 756     print PPP "<BLOCKQUOTE>\n";
 757     print PPP "<TABLE BORDER=2 CELLPADDING=5>\n";
 758     printf PPP "<TR><TH $attr1>%d sites in %d regions</TH></TR>\n",
 759       scalar keys %LST, scalar keys %tab;
 760     printf PPP "<TR><TH $attr1>%s</TH></TR>\n", $STAT;
 761     printf PPP "<TR><TH $attr1>%s</TH></TR>\n", $PROB;
 762     print PPP "<TR>\n";
 763     printf PPP "  <TH $attr2>%s site -- home</TH>\n", $CNF{project_name};
 764     printf PPP "  <TH $attr2>%s</TH>\n",              'type';
 765     printf PPP "  <TH $attr2>%s</TH>\n", 'mirror age,<BR>daily stats';
 766     printf PPP "  <TH $attr2>%s</TH>\n", 'last probe,<BR>probe stats';
 767     printf PPP "  <TH $attr2>%s</TH>\n", 'last stat';
 768     print PPP "</TR>\n";
 769     for my $reg ( sort by_CCS keys %tab ) {
 770         my $itms = $tab{$reg};
 771         my $ccs = exists $CCS{$reg} ? $CCS{$reg} : $reg;
 772         $ccs = nam $reg,
 773           (
 774             scalar @{$itms} > 6
 775             ? sprintf "%s&nbsp;&nbsp;-&nbsp;&nbsp;%d sites",
 776             $ccs,
 777             scalar @{$itms}
 778             : $ccs
 779           );
 780         my $attr3 = "COLSPAN=$COLS BGCOLOR=\"YELLOW\"";
 781         printf PPP "<TR><TH $attr3>$ccs</TH></TR>\n";
 782         for my $itm ( sort by_type_site @{$itms} ) {
 783             my ( $type, $url, $site ) = @{$itm};
 784             my ( $time, $stat, $hstp, $hsts, $vrfy );
 785             my ( $pr_time, $pr_last, $pr_hstp, $pr_hsts );
 786             print PPP "<TR>\n";
 787             printf PPP "  <TD ALIGN=\"RIGHT\">%s&nbsp;&nbsp;%s</TD>\n"
 788               . "  <TD>%s</TD>\n", url( $url, $site ), url( home($url), '@' ),
 789               $type;
 790             if ( exists $RES{$url} ) {
 791                 ( $time, $stat, $vrfy, $hstp, $hsts ) = @{ $RES{$url} };
 792                 $pr_time = $time =~ /^\d+$/
 793                   ? diff $time, $^T - max_age2
 794                   : '&nbsp;';
 795                 $pr_last = $vrfy =~ /^\d+$/
 796                   ? diff $vrfy, $^T - max_vrfy
 797                   : '&nbsp;';
 798                 $pr_hstp = show_hist $hstp ;
 799                 $pr_hsts = show_hist_age $hsts, $time;
 800             }
 801             else {
 802                 ( $pr_time, $pr_last, $pr_hstp, $pr_hsts, $stat ) =
 803                   ( '&nbsp;', '&nbsp;', '', '', '&nbsp;' );
 804             }
 805             $stat = RED $stat if $stat ne 'ok';
 806             printf PPP "  <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n", $pr_time,
 807               $pr_hsts;
 808             printf PPP "  <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n", $pr_last,
 809               $pr_hstp;
 810             printf PPP "  <TD>%s</TD>\n", $stat;
 811             print PPP "</TR>\n";
 812         }
 813     }
 814     print PPP "</TABLE>\n";
 815     print PPP "</BLOCKQUOTE>\n";
 816     if ( $CNF{put_histo} eq 'bottom' ) {
 817         print PPP "<H2>age histogram</H2>\n";
 818         print PPP "<BLOCKQUOTE>\n";
 819         print PPP gen_histogram;
 820         print PPP "</BLOCKQUOTE>\n";
 821     }
 822     print PPP legend;
 823     print PPP "<H3>probe results</H3>\n";
 824     print PPP gen_histogram_probes;
 825     print PPP "<H3>software</H3>\n";
 826     print PPP "<BLOCKQUOTE><TABLE><TR>\n";
 827     my $MIR_IMG = sprintf '<IMG BORDER=2 ALT="mirmon" SRC="%s/mirmon.gif">',
 828       $CNF{icons};
 829     print PPP sprintf "<TH><A HREF=\"%s\">%s</A></TH>\n",
 830       'http://www.cs.uu.nl/people/henkp/mirmon/', $MIR_IMG;
 831     print PPP "<TD>$VER</TD>\n";
 832     print PPP "</TR></TABLE></BLOCKQUOTE>\n";
 833     print PPP $FOOT;
 834     print PPP "</BODY>\n";
 835     print PPP "</HTML>";
 836     if ( print PPP "\n" ) {
 837         close PPP;
 838         if ( -z $TMP ) {
 839             Warn "wrote empty html file; keeping previous version";
 840         }
 841         else { rename $TMP, $PPP or Error "can't rename $TMP, $PPP ($!)"; }
 842     }
 843     else { Error "can't print to $TMP ($!)"; }
 844 }
 845 sub legend {
 846     return <<LEGENDA ;
 847 <H3>legend</H3>
 848 <H4><I>project</I> site -- home</H4>
 849 <BLOCKQUOTE>
 850 <B><I>project</I> site</B> is an url.
 851 The <B>href</B> is the href for the site in the list of mirrors,
 852 usually the root of the mirrored file tree.
 853 The <B>text</B> is the <I>site</I> of that url.
 854 <P>
 855 <B>home</B> (represented by the <B>@</B>-symbol) is an url
 856 pointing to the document root of the site. This pointer is
 857 useful if the <B><I>project</I> site</B> url is invalid,
 858 possibly because the mirror site moved the archive.
 859 </BLOCKQUOTE>
 860 <H4>type</H4>
 861 <BLOCKQUOTE>
 862 Indicates the type (<B>ftp</B> or <B>http</B>) of
 863 the <B><I>project</I> site</B> and <B>home</B> urls.
 864 </BLOCKQUOTE>
 865 <H4>mirror age, daily stats</H4>
 866 <BLOCKQUOTE>
 867 The <B>mirror age</B> is based upon the last successful probe.
 868 <P>
 869 Once a day the status of a mirror site is determined.
 870 The status (represented by a colored block) is appended
 871 to the <B>right</B> of the status history (<I>right</I>
 872 is <I>recent</I>). More precise, the status block is appended
 873 if the last status block was appended 24 (or more) hours ago.
 874 <P>The status of a mirror depends on its age and a few
 875 configuration parameters :
 876 <BLOCKQUOTE>
 877 <TABLE BORDER=1 CELLPADDING=5>
 878 <TR>
 879   <TH ROWSPAN=3>status</TH>
 880   <TH COLSPAN=4>age</TH>
 881 </TR>
 882 <TR>
 883   <TH COLSPAN=2 BGCOLOR="YELLOW">this project</TH>
 884   <TH COLSPAN=2 BGCOLOR="AQUA">in general</TH>
 885 </TR>
 886 <TR>
 887   <TH BGCOLOR="YELLOW">min</TH>
 888   <TH BGCOLOR="YELLOW">max</TH>
 889   <TH BGCOLOR="AQUA">min</TH>
 890   <TH BGCOLOR="AQUA">max</TH>
 891 </TR>
 892 <TR>
 893   <TH><FONT COLOR="GREEN">fresh</FONT></TH>
 894   <TD BGCOLOR="YELLOW" ALIGN="CENTER">0</TD>
 895   <TD BGCOLOR="YELLOW" ALIGN="CENTER">
 896     @{[$CNF{min_sync}]} + @{[$CNF{max_poll}]}</TD>
 897   <TD BGCOLOR="AQUA"   ALIGN="CENTER">0</TD>
 898   <TD BGCOLOR="AQUA"   ALIGN="CENTER">min_sync + max_poll</TD>
 899 </TR>
 900 <TR>
 901   <TH><FONT COLOR="BLUE">oldish</FONT></TH>
 902   <TD BGCOLOR="YELLOW" ALIGN="CENTER">
 903     @{[$CNF{min_sync}]} + @{[$CNF{max_poll}]}</TD>
 904   <TD BGCOLOR="YELLOW" ALIGN="CENTER">
 905     @{[$CNF{max_sync}]} + @{[$CNF{max_poll}]}</TD>
 906   <TD BGCOLOR="AQUA"   ALIGN="CENTER">min_sync + max_poll</TD>
 907   <TD BGCOLOR="AQUA"   ALIGN="CENTER">max_sync + max_poll</TD>
 908 </TR>
 909 <TR>
 910   <TH><FONT COLOR="RED">old</FONT></TH>
 911   <TD BGCOLOR="YELLOW" ALIGN="CENTER">
 912     @{[$CNF{max_sync}]} + @{[$CNF{max_poll}]}</TD>
 913   <TD BGCOLOR="YELLOW" ALIGN="CENTER">&infin;</TD>
 914   <TD BGCOLOR="AQUA"   ALIGN="CENTER">max_sync + max_poll</TD>
 915   <TD BGCOLOR="AQUA"   ALIGN="CENTER">&infin;</TD>
 916 </TR>
 917 <TR>
 918   <TH><FONT COLOR="BLACK">bad</FONT></TH>
 919   <TH COLSPAN=4 BGCOLOR="BLACK">
 920     <FONT COLOR="WHITE">the site or mirror tree was never found</FONT></TH>
 921 </TR>
 922 </TABLE>
 923 </BLOCKQUOTE>
 924 </BLOCKQUOTE>
 925 <H4>last probe, probe stats</H4>
 926 <BLOCKQUOTE>
 927 <B>Last probe</B> indicates when the last successful probe was made.
 928 <B>Probe stats</B> gives the probe history (<I>right</I> is <I>recent</I>).
 929 A probe is either a
 930 <FONT COLOR="GREEN"><B>success</B></FONT> or a
 931 <FONT COLOR="RED"><B>failure</B></FONT>.
 932 </BLOCKQUOTE>
 933 <H4>last stat</H4>
 934 <BLOCKQUOTE>
 935 <B>Last stat</B> gives the status of the last probe.
 936 </BLOCKQUOTE>
 937 LEGENDA
 938 }
 939 sub start_date {
 940     my $url     = shift;
 941     my $CMD     = shift;
 942     my $TIMEOUT = $CNF{timeout};
 943     my $src     = $HREF{ lc site $url } || $url;
 944     $CMD =~ s/%TIMEOUT%/$TIMEOUT/g;
 945     $CMD =~ s/%URL%/$src/g;
 946     printf "*** SUBSTITUTE site %s\n+  url %s\n+  %s\n", site($url),
 947       $HREF{ lc site $url }, $CMD
 948       if $HREF{ lc site $url } and $opt{v};
 949     my $WGT = new IO::Pipe;
 950     my $res = $WGT->reader( split ' ', $CMD );
 951     if ($res) {
 952         $WGT->blocking(0);
 953         $GET->add($WGT);
 954         $URL{$WGT} = $url;
 955     }
 956     else { err $url, 'no pipe'; }
 957 }
 958 sub get_date {
 959     my $WGT  = shift;
 960     my $url  = $URL{$WGT};
 961     my $time = undef;
 962     $WGT->blocking(1);
 963     unless ( $WGT->eof() ) { $time = $WGT->getline(); }
 964     $GET->remove($WGT);
 965     $WGT->flush;
 966     $WGT->close;
 967     return err $url, 'no time' unless defined $time;
 968     return err $url, "empty" if $time =~ /^\s*$/;
 969     $time = ( split ' ', $time )[0];
 970     if ( $time !~ /^\d+$/ ) {
 971         $time = htmlquote $time ;
 972         $time = substr( $time, 0, 15 ) . '..' if length $time > 15;
 973           err $url, "'$time'";
 974     }
 975     else { res $url, $time, 'ok'; }
 976 }
 977 sub get_dates {
 978     my $CMD = shift;
 979     my @QUE;
 980     my $PAR     = $CNF{max_probes};
 981     my $cnt_LST = scalar keys %LST;
 982     for my $url ( sort keys %LST ) {
 983         if ( $opt{get} eq 'all' or !exists $OLD{$url} ) { push @QUE, $url; }
 984         elsif ( $opt{get} eq 'update' ) {
 985             my $stat = $OLD{$url}[1];
 986             my $vrfy = $OLD{$url}[2];
 987             my $lprb = $OLD{$url}[5];
 988             if (
 989                 (
 990                     $lprb eq 'undef'
 991                     or aprx_le $lprb,
 992                     $^T - tim_to_s $CNF {min_poll}
 993                 )
 994                 and (
 995                     $stat ne 'ok' or aprx_le $vrfy,
 996                     $^T - tim_to_s $CNF {max_poll}
 997                 )
 998               )
 999             {
1000                 push @QUE, $url;
1001             }
1002             elsif ( $CNF{randomize} and 0 == int rand $cnt_LST ) {
1003                 push @QUE, $url;
1004             }
1005             else { $RES{$url} = $OLD{$url}; }
1006         }
1007         else { Error "unknown opt_get '$opt{get}'"; }
1008     }
1009     while (@QUE) {
1010         while ( $GET->count() < $PAR and @QUE ) {
1011             my $url = shift @QUE;
1012             if ( gethost site $url ) { start_date $url, $CMD; }
1013             else                     { err $url, 'site not found'; }
1014         }
1015         my @can_read = $GET->can_read(0);
1016         printf "que %d, get %d, can %d\n", scalar @QUE, $GET->count(),
1017           scalar @can_read
1018           if $opt{v};
1019         for my $can_read (@can_read) { get_date $can_read ; }
1020         sleep 1;
1021     }
1022     my $stop = time + $CNF{timeout} + 10;
1023     while ( $GET->count() and time < $stop ) {
1024         sleep 1;
1025         my @can_read = $GET->can_read(0);
1026         printf "wait %2d, get %d, can %d\n", $stop - scalar time, $GET->count(),
1027           scalar @can_read
1028           if $opt{v};
1029         for my $can_read (@can_read) { get_date $can_read ; }
1030     }
1031     for my $WGT ( $GET->handles() ) {
1032         my $url = $URL{$WGT};
1033           err $url, 'hangs';
1034     }
1035 }
1036 get_conf_opt;
1037 get_ccs $CNF {countries};
1038 get_state $CNF {state};
1039 get_list $CNF {mirror_list};
1040 if ( $opt{get} ) {
1041     get_dates $CNF {probe};
1042     put_state $CNF {state};
1043 }
1044 else { %RES = %OLD }
1045 gen_page $CNF {web_page};
1046 __END__
1047 =pod
1048 =head1 NAME
1049   mirmon - monitor the state of mirrors
1050 =head1 SYNOPSIS
1051   mirmon [ -v ] [ -q ] [ -t timeout ] [ -get opt ] [ -c conf ]
1052 =head1 OPTIONS
1053   option v   : be verbose
1054   option q   : be quiet
1055   option t   : set timeout [ default 300 ] ;
1056   option get : 'all'    : probe all sites
1057              : 'update' : probe a selection of the sites (see doc)
1058   option c   : configuration file ; default list :
1059                ./mirmon.conf $HOME/.mirmon.conf /etc/mirmon.conf
1060   -------------------------------------------------------------------
1061   Documentation : the program contains 'pod' style documentation.
1062   Extract the doc with 'pod2text mirmon' or 'pod2html mirmon OUT', etc.
1063   -------------------------------------------------------------------
1064 =head1 USAGE
1065   The program is intended to be run by cron every hour.
1066     42 * * * * perl /path/to/mirmon -q -get update
1067   It quietly probes a subset of the sites in a given list,
1068   writes the results in the 'state' file and generates a web page
1069   with the results. The subset contains the sites that are new, bad
1070   and/or not probed for a specified time.
1071   When no 'get' option is specified, the program just generates a
1072   new web page from the last known state.
1073   The program checks the mirrors by running a (user specified)
1074   program on a pipe. A (user specified) number of probes is
1075   run in parallel using nonblocking IO. When something can be
1076   read from the pipe, it switches the pipe to blocking IO and
1077   reads one line from the pipe. Then it flushes and closes the
1078   pipe. No attempt is made to kill the probe.
1079   The probe should return something that looks like "1043625600\n",
1080   that is, a timestamp followed by a newline. The exit status of
1081   the probe is ignored.
1082 =head1 CONFIG FILE
1083 =head2 location
1084   A config file can be specified with the -c option.
1085   If -c is not used, the program looks for a config file in
1086   -- ./mirmon.conf
1087   -- $HOME/.mirmon.conf
1088   -- /etc/mirmon.conf
1089 =head2 syntax
1090   A config file looks like this :
1091     +--------------------------------------------------
1092     |# lines that start with '#' are comment
1093     |# blank lines are ignored too
1094     |# tabs are replaced by a space
1095     |
1096     |# the config entries are 'key' and 'value' pairs
1097     |# a 'key' begins in column 1
1098     |# the 'value' is the rest of the line
1099     |somekey  A_val B_val ...
1100     |otherkey X_val Y_val ...
1101     |
1102     |# indented lines are glued
1103     |# the next three lines mean 'somekey part1 part2 part3'
1104     |somekey part1
1105     |  part2
1106     |  part3
1107     |
1108     |# lines starting with a '+' are concatenated
1109     |# the next three lines mean 'somekey part1part2part3'
1110     |somekey part1
1111     |+ part2
1112     |+ part3
1113     |
1114     |# lines starting with a '.' are glued too
1115     |# don't use a '.' on a line by itself
1116     |# 'somekey' gets the value "part1\n part2\n part3"
1117     |somekey part1
1118     |. part2
1119     |. part3
1120     +--------------------------------------------------
1121 =head1 CONFIG FILE : required entries
1122 =head2 project_name <name>
1123   Specify a short plaintext name for the project.
1124     project_name Apache
1125     project_name CTAN
1126 =head2 project_url <url>
1127   Specify an url pointing to the 'home' of the project.
1128     project_url http://www.apache.org/
1129 =head2 mirror_list <file name>
1130   Specify the file containing the mirrors to probe.
1131   Two formats are supported :
1132   -- plain : lines like
1133        us http://www.tux.org/
1134        nl http://apache.cs.uu.nl/dist/
1135   -- apache : lines like those in the apache mirrors.list
1136        ftp  us ftp://ftp.tux.org/pub/net/apache/dist/ user@tux.org
1137        http nl http://apache.cs.uu.nl/dist/ user@cs.uu.nl
1138   Specify the required format with 'list_style' (see below).
1139   The default style is 'plain'.
1140   If the url part of a line doesn't end in a slash ('/'), mirmon
1141   adds a slash and issues a warning unless it is in quiet mode.
1142 =head2 web_page <file name>
1143   Specify where the html report page is written.
1144 =head2 icons <directory name>
1145   Specify the directory where the icons can be found.
1146 =head2 probe <program + arguments>
1147   Specify the program+args to probe the mirrors. Example:
1148     probe /sw/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME
1149   Before the program is started, %TIMEOUT% and %URL% are
1150   substituted with the proper timeout and url values.
1151   Here it is assumed that each hour the root server writes
1152   a timestamp in /path/to/archive/TIME, for instance with
1153   a crontab entry like
1154     42 * * * * perl -e 'printf "%s\n", time' > /path/to/archive/TIME
1155   Mirmon reads one line of output from the probe and interprets
1156   the first word on that line as a timestamp ; for example :
1157     1043625600
1158     1043625600 Mon Jan 27 00:00:00 2003
1159     1043625600 www.apache.org Mon Jan 27 00:00:00 2003
1160 =head2 state <file name>
1161   Specify where the file containing the state is written.
1162   The program reads this file on startup and writes the
1163   file when mirrors are probed (-get is specified).
1164 =head2 countries <file name>
1165   Specify the file containing the country codes;
1166   The file should contain lines like
1167     us - united states
1168     nl - netherlands
1169   The mirmon package contains a recent ISO list.
1170 =head1 CONFIG FILE : optional entries
1171 =head2 max_probes <number>
1172   Optionally specify the number of parallel probes (default 25).
1173 =head2 timeout <seconds>
1174   Optionally specify the timeout for the probes (default 300).
1175   After the last probe is started, the program waits for
1176   <timeout> + 10 seconds, cleans up and exits.
1177 =head2 project_logo <logo>
1178   Optionally specify (the SRC of the IMG of) a logo to be placed
1179   top right on the page.
1180     project_logo /icons/apache.gif
1181     project_logo http://www.apache.org/icons/...
1182 =head2 htm_head <html>
1183   Optionally specify some HTML to be placed before </HEAD>.
1184     htm_head
1185       <link REL=StyleSheet HREF="/style.css" TYPE="text/css">
1186 =head2 htm_top <html>
1187   Optionally specify some HTML to be placed near the top of the page.
1188   The supplied text is placed between <P> and </P>.
1189     htm_top testing 1, 2, 3
1190 =head2 htm_foot <html>
1191   Optionally specify HTML to be placed near the bottom of the page.
1192     htm_foot
1193       <HR>
1194       <A HREF="..."><IMG SRC="..." BORDER=0></A>
1195       <HR>
1196 =head2 put_histo top|bottom|nowhere
1197   Optionally specify where the age histogram must be placed.
1198   The default is 'top'.
1199 =head2 min_poll <time spec>
1200   For 'min_poll' see next item. A <time spec> is a number followed by
1201   a unit 's' (seconds), or 'm' (minutes), or 'h' (hours), or 'd' (days).
1202   For example '3d' (three days) or '36h' (36 hours).
1203 =head2 max_poll <time spec>
1204   Optionally specify the maximum probe interval. When the program is
1205   called with option '-get update', all sites are probed which are :
1206   -- new : the site appears in the list, but there is no known state
1207   -- bad : the last probe of the site was unsuccessful
1208   -- old : the last probe was more than 'max_poll' ago.
1209   Sites are not probed if the last probe was less than 'min_poll' ago.
1210   So, if you specify
1211     min_poll 4h
1212     max_poll 12h
1213   the 'reachable' sites are probed twice daily and the 'unreachable'
1214   sites are probed at most six times a day.
1215   The default 'min_poll' is '1h' (1 hour).
1216   The default 'max_poll' is '4h' (4 hours).
1217 =head2 min_sync <time spec>
1218   Optionally specify how often the mirrors are required to
1219   make an update. The default 'min_sync' is '1d' (1 day).
1220 =head2 max_sync <time spec>
1221   Optionally specify the maximum allowable sync interval.
1222   Sites exceeding the limit will be considered 'old'.
1223   The default 'max_sync' is '2d' (2 days).
1224 =head2 no_randomize
1225   With a low probablility, mirmon probes mirrors that would
1226   otherwise not be probed. In the long run, this balances
1227   the number of mirror probes over the hourly mirmon runs.
1228   Specifically, if there are N mirrors in the list and some
1229   mirmon run would probe K sites, on average (N-K)/N extra
1230   sites will be probed.
1231   If you don't want this behaviour, use 'no_randomize'.
1232 =head2 list_style plain|apache
1233   Optionally specify the format ('plain' or 'apache') of the
1234   mirror-list. See the description of 'mirror_list' above.
1235   The default list_style is 'plain'.
1236 =head2 site_url <site> <url>
1237   Optionally specify a substitute url for a site. When access to
1238   a site is restricted (in Australia, for instance), another
1239   (sometimes secret) url can be used to probe the site. The <site>
1240   of an url is the part between '://' and the first '/'.
1241 =head2 env <key> <value>
1242   Optionally specify an environment variable.
1243 =head2 include <file name>
1244   Optionally specify a file to include. The specified file is processed
1245   'in situ'. After the specified file is read and processed, config
1246   processing is resumed in the file where the 'include' was encountered.
1247   The 'include' depth is unlimited. However, it is a fatal error to
1248   include a file twice under the same name.
1249 =head2 show
1250   When the config processor encounters the 'show' command, it
1251   dumps the content of the current config to standout, if option
1252   -v is specified. This is intented for debugging.
1253 =head2 exit
1254   When the config processor encounters the 'exit' command, it
1255   terminates the program. This is intented for debugging.
1256 =head1 STATE FILE FORMAT
1257   The state file consists of lines; one line per site.
1258   Each line consists of white space separated fields.
1259   The seven fields are :
1260 =head2 field 1 : url
1261   The url as given in the mirror list.
1262 =head2 field 2 : age
1263   The age of the site, or 'undef' if no probe was ever successful.
1264 =head2 field 3 : status last probe
1265   The status of the last probe.
1266 =head2 field 4 : time last succesful probe
1267   The timestamp of the last succesful probe or 'undef'
1268   if the site was never successfully probed.
1269 =head2 field 5 : probe history
1270   The probe history is a list of 's' (for success) and 'f' (for failure)
1271   characters indicating the result of the probe. New results are appended
1272   whenever the site is probed.
1273 =head2 field 6 : state history
1274   The state history consists of a timestamp, a '-' char, and a list of
1275   chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old)
1276   or 'z' (bad). The timestamp indicates when the state history was last
1277   updated. The state history is updated when the state file is updated
1278   and the last update of the history state was 24 (or more) hours ago.
1279   The status is determined by the site's age and a few configuration
1280   parameters. The details are explained in the legend of the report page.
1281 =head2 field 7 : last probe
1282   The timestamp of the last probe.
1283 =head1 INSTALLATION
1284 =over
1285 =item *
1286   The '#!' path for perl is probably wrong.
1287 =back
1288 =head1 AUTHOR
1289 =begin html
1290 <BLOCKQUOTE>
1291   &copy; 2003
1292   <A HREF="http://www.cs.uu.nl/staff/henkp.html">Henk P. Penning</A>,
1293   <A HREF="http://www.cs.uu.nl/">Computer Science Department</A>,
1294   <A HREF="http://www.uu.nl/">Utrecht University</A>
1295   <BR>
1296   $Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $
1297 </BLOCKQUOTE>
1298 =end html
1299 =begin text
1300   (c) 2003 Henk P. Penning, Computer Science Department, Utrecht University
1301   http://www.cs.uu.nl/staff/henkp.html -- penning@cs.uu.nl
1302 =end text
1303 =cut