mirmon/mirmon

   1 #! /usr/bin/perl -w
   2
   3 # Copyright (c) 2003-2014 Henk Penning, all rights reserved.
   4 # penning@uu.nl, http://www.staff.science.uu.nl/~penni101/
   5 # Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28.
   6 #
   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 # Peter Pöml for MirrorBrain support ; Jeremy Olexa, Karl Berry, Roland
  27 # Pelzer for suggestions regarding rsync support.
  28
  29 use strict ;
  30
  31 our $PRG = 'mirmon' ;
  32 our $VER = "2.10" ;
  33
  34 our $DEF_TIMEOUT = 300 ;
  35 our $HIST        = 14 ;
  36 our $TIM_PAT     = '^(\d+)([smhd])$' ;
  37 our %APA_TYPES   = () ; $APA_TYPES { $_ } ++ for qw(backup ftp http rsync) ;
  38 our %GET_OPTS    = () ; $GET_OPTS  { $_ } ++ for qw(all update url) ;
  39 our $HIST_DELTA  = 24 * 60 * 60 ;
  40 our $APRX_DELTA  = 300 ;
  41 our $HOME        = 'http://www.staff.science.uu.nl/~penni101/mirmon/' ;
  42
  43 package Base ; #####################################################
  44
  45 use base 'Exporter' ;
  46
  47 our ( @ISA, @EXPORT ) ;
  48 BEGIN
  49   { @ISA = qw(Exporter) ;
  50     @EXPORT =
  51       qw(aprx_eq aprx_ge aprx_le aprx_gt aprx_lt
  52          URL NAM SMA BLD NSS TAB BQ TR TH TD TDr RED GRN H1 H2 H3
  53          s4tim pr_interval pr_diff
  54         ) ;
  55   }
  56
  57 sub Version { "$PRG version $VER" ; }
  58 sub version { "$PRG-$VER" ; }
  59 sub DEF_TIMEOUT { $DEF_TIMEOUT ; }
  60 sub is_get_opt  { my $opt = shift ; exists $GET_OPTS { $opt } ; }
  61
  62 sub getset
  63   { my $self = shift ;
  64     my $attr = shift ;
  65     if ( @_ ) { $self -> { $attr } = shift ; }
  66     die "no attr '$attr'" unless exists $self -> { $attr } ;
  67     $self -> { $attr } ;
  68   }
  69
  70 sub mk_method
  71   { my $self = shift ;
  72     my $attr = shift ;
  73     sprintf 'sub %s { my $self = shift ; $self -> getset ( "%s",  @_ ) ; }'
  74       , $attr, $attr ;
  75   }
  76
  77 sub mk_methods
  78   { my $self = shift ;
  79     join "\n", map { Base -> mk_method ( $_ ) ; } @_ ;
  80   }
  81
  82 sub aprx_eq { my ( $t1, $t2 ) = @_ ; abs ( $t1 - $t2 ) < $APRX_DELTA ; }
  83 sub aprx_ge { my ( $t1, $t2 ) = @_ ; $t1 > $t2 or      aprx_eq $t1, $t2 ; }
  84 sub aprx_le { my ( $t1, $t2 ) = @_ ; $t1 < $t2 or      aprx_eq $t1, $t2 ; }
  85 sub aprx_gt { my ( $t1, $t2 ) = @_ ; $t1 > $t2 and not aprx_eq $t1, $t2 ; }
  86 sub aprx_lt { my ( $t1, $t2 ) = @_ ; $t1 < $t2 and not aprx_eq $t1, $t2 ; }
  87
  88 sub URL { sprintf '<A HREF="%s">%s</A>', $_[0], $_[1] ; }
  89 sub NAM { sprintf '<A NAME="%s">%s</A>', $_[0], $_[1] ; }
  90 sub SMA { sprintf "<FONT SIZE=\"-1\">%s</FONT>", $_[0] ; }
  91 sub BLD { sprintf "<B>%s</B>", $_[0] ; }
  92 sub NSS { sprintf SMA('%s&nbsp;site%s'), $_[0], ( $_[0] == 1 ? '' : 's' ) ; }
  93 sub TAB { sprintf "<TABLE BORDER=2 CELLPADDING=3>%s</TABLE>", $_[0] ; }
  94 sub BQ  { sprintf "<BLOCKQUOTE>\n%s\n</BLOCKQUOTE>\n", $_[0] ; }
  95 sub TR  { sprintf "<TR>%s</TR>\n", $_[0] ; }
  96 sub TH  { sprintf "<TH>%s</TH>\n", $_[0] ; }
  97 sub TD  { sprintf "<TD>%s</TD>\n", $_[0] ; }
  98 sub H1  { sprintf "<H1>%s</H1>\n", $_[0] ; }
  99 sub H2  { sprintf "<H2>%s</H2>\n", $_[0] ; }
 100 sub H3  { sprintf "<H3>%s</H3>\n", $_[0] ; }
 101 sub TDr { sprintf "<TD ALIGN=\"RIGHT\">%s</TD>\n", $_[0] ; }
 102 sub RED { sprintf "<FONT COLOR=\"RED\">%s</FONT>", $_[0] ; }
 103 sub GRN { sprintf '<FONT COLOR="GREEN">%s</FONT>', $_[0] ; }
 104
 105 sub s4tim
 106   { my $tim = shift ;
 107     my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 ) ;
 108     die "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o ;
 109     my $m = $1 ; my $u = $2 ;
 110     return $m * $tab { $u } ;
 111   }
 112
 113 sub pr_interval
 114   { my $s = shift ;
 115     my ( $magn, $unit ) ;
 116     my $mins  = $s / 60          ; my $m = int ( $mins + 0.5 ) ;
 117     my $hours = $s / ( 60 * 60 ) ; my $h = int ( $hours + 0.5 ) ;
 118
 119     if ( $s < 50 )
 120       { $magn = $s ; $unit = 'second' ; }
 121     elsif ( $m < 50 )
 122       { $magn = $m ; $unit = 'minute' ; }
 123     elsif ( $h < 36 )
 124       { $magn = $h ; $unit = 'hour' ; }
 125     else
 126       { $magn = sprintf "%.1f", $hours / 24 ; $unit = 'day' ; }
 127
 128     $unit .= 's' unless $magn == 1 ;
 129
 130     return "$magn $unit" ;
 131   }
 132
 133 sub pr_diff
 134   { my $time = shift ;
 135     my $max  = shift ;
 136     my $res ;
 137
 138     if ( $time == $^T )
 139       { $res = BLD 'renewed' ; }
 140     else
 141       { $res = pr_interval $^T - $time ;
 142         $res = BLD RED $res if aprx_lt $time, $max ;
 143       }
 144     return $res ;
 145   }
 146
 147 sub exp_date
 148   { my @day = qw(Sun Mon Tue Wed Thu Fri Sat) ;
 149     my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ;
 150     my @gmt = gmtime time + 3600 ;
 151     sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT"
 152       , $day [ $gmt [ 6 ] ]
 153       , $gmt [ 3 ]
 154       , $mon [ $gmt [ 4 ] ]
 155       , $gmt [ 5 ] + 1900
 156       , @gmt [ 2, 1, 0 ]
 157       ;
 158   }
 159
 160 sub htmlquote
 161   { my $x = shift ;
 162     $x =~ s/&/&amp;/g ;
 163     $x =~ s/</&lt;/g ;
 164     $x =~ s/>/&gt;/g ;
 165     return $x ;
 166   }
 167
 168 package Mirmon ; ###################################################
 169
 170 BEGIN { use base 'Base' ; Base -> import () ; }
 171
 172 use IO::Select ;
 173 use Net::hostent ;
 174
 175   { my %opt = ( v => 0 , d => 0 , q => 0 ) ;
 176     sub _opt
 177       { my ( $key, $val ) = @_ ;
 178         my $res ;
 179         unless ( exists $opt { $key } )
 180           { warn "unknown Mirmon option '$key'\n" ; }
 181         else
 182           { $res = $opt { $key } ;
 183             $opt { $key } = $val if defined $val ;
 184           }
 185         $res ;
 186       }
 187   }
 188
 189 sub verbose { _opt ( 'v', shift ) ; }
 190 sub quiet   { _opt ( 'q', shift ) ; }
 191 sub debug   { _opt ( 'd', shift ) ; }
 192
 193 eval Base -> mk_methods ( qw(conf state regions) ) ;
 194
 195 sub config_list
 196   { my $self = shift ;
 197     my $home = ( getpwuid $< ) [ 7 ] or die "can get homedir '$<' ($!)" ;
 198     ( 'mirmon.conf', "$home/.mirmon.conf", '/etc/mirmon.conf' ) ;
 199   }
 200
 201 sub new
 202   { my $self = shift ;
 203     my $path = shift ;
 204     my $res  = bless {}, $self ;
 205     $res -> get_config ( $path ) ;
 206     $res -> get_state ;
 207     $res -> get_regions ;
 208     $res ;
 209   }
 210
 211 sub find_config
 212   { my $self = shift ;
 213     my $arg = shift ;
 214     my @LIST = $arg ? ( $arg ) : Mirmon -> config_list ;
 215     for my $conf ( @LIST ) { return $conf if -r $conf and ! -d $conf ; }
 216     die sprintf "can't find a config file :\n  %s\n" , join "\n  ", @LIST ;
 217   }
 218
 219 sub get_config
 220   { my $self = shift ;
 221     my $path = shift ;
 222     my $file = $self -> find_config ( $path ) ; # or die
 223     $self -> conf ( Mirmon::Conf -> new ( $file ) ) ;
 224   }
 225
 226 sub get_state
 227   { my $self = shift ;
 228     my $conf = $self -> conf ;
 229     my $name = $conf -> project_name ;
 230     my $state = $conf -> state ;
 231     my $res = {} ;
 232     open STATE, $state or die "can't open $state ($!)" ;
 233     for my $line ( <STATE> )
 234       { chop $line ;
 235         my $mirror = Mirmon::Mirror -> new ( $self, $line ) ;
 236         $res -> { $mirror -> url } = $mirror ;
 237       }
 238     close STATE ;
 239
 240     my $mlist = $conf -> mirror_list ;
 241     my $style = $conf -> list_style ;
 242     my %in_list = () ;
 243     my $changes = '' ;
 244     open MLIST, $mlist or die "can't open $mlist ($!)" ;
 245     for my $line ( <MLIST> )
 246       { chop $line ;
 247         next if $line =~ /^#/ ;
 248         next if $line =~ /^\s*$/ ;
 249         my ( $reg, $url, $mail ) ;
 250         if ( $style eq 'plain' )
 251           { ( $reg, $url, $mail ) = split ' ', $line ; }
 252         elsif ( $style eq 'apache' )
 253           { my $apache_type ;
 254             ( $apache_type, $reg, $url, $mail ) = split ' ', $line ;
 255             unless (  defined $APA_TYPES { $apache_type } )
 256               { print "*** strange type in $url ($apache_type)\n"
 257                   unless Mirmon::quiet ;
 258                 next ;
 259               }
 260           }
 261
 262         if ( $conf -> add_slash and $url !~ m!/$! )
 263           { print "*** appended '/' to $url\n" unless Mirmon::quiet ;
 264             $url .= '/' ;
 265           }
 266
 267         $in_list { $url } ++ ;
 268
 269         unless ( exists $res -> { $url } )
 270           { $changes .= sprintf "added %s\n", $url unless Mirmon::quiet ;
 271             $res -> { $url } = Mirmon::Mirror -> init ( $self, $url ) ;
 272           }
 273         my $mirror = $res -> { $url } ;
 274         $mirror -> region ( $reg ) ;
 275         $mirror -> mail ( $mail || '' ) ;
 276       }
 277     close MLIST ;
 278
 279     for my $url ( sort keys %$res )
 280       { # printf "%s\n", $res -> { $url } -> state ;
 281         unless ( exists $in_list { $url } )
 282           { $changes .= sprintf "removed %s\n", $url unless Mirmon::quiet ;
 283             delete $res -> { $url } ;
 284           }
 285       }
 286     printf "changes in mirror-list for '%s':\n%s", $name, $changes
 287       if $changes ;
 288     $self -> state ( $res ) ;
 289   }
 290
 291 sub put_state
 292   { my $self  = shift ;
 293     my $state = $self -> state ;
 294     my $file  = $self -> conf -> state ;
 295     my $TMP = "$file.tmp" ;
 296     open TMP, ">$TMP" or die "can't write '$TMP' ($!)" ;
 297     for my $url ( sort keys %$state )
 298       { printf TMP "%s\n", $state -> { $url } -> state
 299           or die "can't print $url to $TMP ($!)" ;
 300       }
 301     close TMP ;
 302
 303     if ( -z $TMP )
 304       { warn "wrote empty state file; keeping previous version" ; }
 305     else
 306       { rename $TMP, $file or die "can't rename '$TMP', '$file' ($!)" ; }
 307   }
 308
 309 sub get_regions
 310   { my $self = shift ;
 311     my $file =  $self -> conf -> countries ;
 312     open REGS, $file or die "can't open countries '$file' ($!)" ;
 313     while ( <REGS> )
 314       { chop ;
 315         next if /^#/ ;
 316         my ( $code, $dash, $reg ) = split ' ', $_, 3 ;
 317         $self -> { regions } { lc $code } = $reg ;
 318       }
 319     close REGS ;
 320   }
 321
 322 sub _cmp_ccs
 323   { my $ccs = shift ;
 324     my $x  = shift ;
 325     my $y  = shift ;
 326     my $xx = $ccs -> { $x } ;
 327     my $yy = $ccs -> { $y } ;
 328     if ( ! defined $xx and ! defined $yy )
 329       { $x cmp $y ; }
 330     elsif ( ! defined $xx )
 331       { -1 ; }
 332     elsif ( ! defined $yy )
 333       { +1 ; }
 334     else
 335       { $xx cmp $yy ; }
 336   }
 337
 338 sub _pr_round
 339   { my $x = shift ;
 340     my $i = int $x ;
 341     my $f = $x - $i ;
 342     $i + ( rand 1 < $f ? 1 : 0 ) ;
 343   }
 344
 345 sub _diag_qs
 346   { my $qs = shift ;
 347     join ', ', map { sprintf "%s %s" , $_, scalar @{ $qs -> { $_ } } ; }
 348       sort keys %$qs ;
 349   }
 350
 351 sub _rpick
 352   { my $row = shift ;
 353     die "_rpick : row empty" unless @$row ;
 354     my $idx = int rand @$row ;
 355     my $res = $row -> [ $idx ] ;
 356     $row -> [ $idx ] = $row -> [ $#{$row} ] ;
 357     pop @$row ;
 358     $res ;
 359   }
 360
 361 sub _buck_split
 362   { my $que = shift ;
 363     my $tmp = [] ;
 364     for my $mirr ( @$que )
 365       { my $lp = $mirr -> last_probe ;
 366         my $hr = int ( ( $^T - $lp ) / 60 / 60 + 0.5 ) ;
 367         push @{ $tmp -> [ $hr ] }, $mirr ;
 368       }
 369     [ grep defined $_, @$tmp ] ;
 370   }
 371
 372 sub _buck_join
 373   { my $bucks = shift ;
 374     my $res = [] ;
 375     push @$res, @$_ for @$bucks ;
 376     $res ;
 377   }
 378
 379 sub _buck_pick
 380   { my $bucks = shift ;
 381     die "buck_pick : bucks empty" unless @$bucks ;
 382     my $buck = ( sort { @$b <=> @$a } @$bucks ) [ 0 ] ;
 383     _rpick $buck ;
 384   }
 385
 386 sub _randomize
 387   { my $ques = shift ;
 388     my $poll = shift ;
 389     my $hrs  = int ( $poll / 60 / 60 + 0.5 ) ;
 390
 391     my $diag1 = _diag_qs $ques ;
 392
 393     my $todos = $ques -> { todo } ;
 394     my $dones = $ques -> { done } ;
 395     my $cnt   = @$todos + @$dones ;
 396     my $avg   = $hrs ? $cnt / $hrs : 0 ;
 397     my $iavg  = _pr_round $avg ;
 398     my $pick  = 0 ;
 399     my $bucks = _buck_split $dones ;
 400
 401     while ( @$todos < $iavg and $pick < @$dones )
 402       { push @$todos, _buck_pick $bucks ;
 403         $pick ++ ;
 404       }
 405
 406     $ques -> { done } = _buck_join $bucks ;
 407
 408     sprintf ''
 409       . "  hrs %s, %s\n"
 410       . "  avg %.2f -> %d , picked %d ; queued %s\n"
 411       . "  hrs %s, %s\n"
 412       , $hrs, $diag1
 413       , $avg, $iavg, $pick, scalar @$todos
 414       , $hrs, _diag_qs ( $ques )
 415       ;
 416   }
 417
 418 sub get_dates
 419   { my $self  = shift ;
 420     my $get   = shift ;
 421     my $URL   = shift ;
 422     my $state = $self -> state ;
 423     my $conf  = $self -> conf ;
 424     my $CMD   = $conf -> probe ;
 425     my $PAR   = $conf -> max_probes ;
 426     my %m4h   = () ;
 427     my @QUE   = () ;
 428     my $GET   = IO::Select -> new () ;
 429     my $ques  = {} ;
 430     for my $col ( qw(new red grn xtr) )
 431       { $ques -> { $col } { $_ } = [] for qw(done todo) ; }
 432     my $max_poll = s4tim $conf -> max_poll ;
 433     my $min_poll = s4tim $conf -> min_poll ;
 434
 435     if ( Mirmon::verbose ) { printf "mirrors %d\n", scalar keys %$state ; }
 436
 437     if ( $get eq 'all' )
 438       { @QUE = sort { $a -> url cmp $b -> url } values %$state ; }
 439     elsif ( $get eq 'url' )
 440       { @QUE = ( $state -> { $URL } ) ; }
 441     elsif ( $get eq 'update' )
 442       { my $maxp = $^T - $max_poll ;
 443         my $minp = $^T - $min_poll ;
 444
 445 if ( Mirmon::verbose )
 446   { printf "max_poll %s\n", scalar localtime $maxp ;
 447     printf "min_poll %s\n", scalar localtime $minp ;
 448   }
 449         for my $url ( sort keys %$state )
 450           { my $mirror = $state -> { $url } ;
 451             my $stat = $mirror -> last_status ;
 452             my $vrfy = $mirror -> last_ok_probe ;
 453             my $lprb = $mirror -> last_probe ;
 454             my $col ;
 455             my $que ;
 456             if ( $stat eq 'undef' ) # never probed ; new mirror ; todo
 457               { $col = 'new' ; $que = 'todo' ; }
 458             elsif ( $conf -> get_xtr ( $mirror -> region ) )
 459               { $col = 'xtr' ; $que = 'todo' ; }
 460             else
 461               { my $poll = $stat eq 'ok' ? $maxp : $minp ;
 462                 $col     = $stat eq 'ok' ? 'grn' : 'red' ;
 463                 $que     = ( aprx_le $lprb, $poll ) ? 'todo' : 'done' ;
 464               }
 465             push @{ $ques -> { $col } { $que } }, $mirror ;
 466           }
 467
 468         if ( $conf -> randomize )
 469           { my $msg = "randomize green\n" ;
 470             $msg .= _randomize $ques -> { grn }, $max_poll ;
 471             $msg .= "randomize red\n" ;
 472             $msg .= _randomize $ques -> { red }, $min_poll ;
 473             print $msg if Mirmon::verbose ;
 474           }
 475         @QUE =
 476           ( @{ $ques -> { new } { todo } }
 477           , @{ $ques -> { red } { todo } }
 478           , @{ $ques -> { grn } { todo } }
 479           , @{ $ques -> { xtr } { todo } }
 480           ) ;
 481       }
 482     else
 483       { die "unknown opt_get '$get'" ; }
 484
 485     if ( Mirmon::verbose ) { printf "queued %d\n\n", scalar @QUE ; }
 486
 487     while ( @QUE )
 488       { my $started = 0 ;
 489         while ( $GET -> count () < $PAR and @QUE )
 490           { my $mirror = shift @QUE ;
 491             if ( gethost $mirror -> site )
 492               { my $handle = $mirror -> start_probe ;
 493                 $m4h { $handle } = $mirror ;
 494                 $GET -> add ( $handle ) ;
 495                 $started ++ ;
 496               }
 497             else
 498               { $mirror -> update ( 0, 'site_not_found', undef ) ; }
 499           }
 500
 501         my @can_read = $GET -> can_read ( 0 ) ;
 502
 503         printf "queue %d, started %d, probes %d, can_read %d\n",
 504           scalar @QUE, $started, $GET -> count (), scalar @can_read
 505             if Mirmon::verbose ;
 506
 507         for my $handle ( @can_read )
 508           { # order is important ; wget's hang if/when actions are reversed
 509             $GET -> remove ( $handle ) ;
 510             $m4h { $handle } -> finish_probe ( $handle ) ;
 511           }
 512
 513         sleep 1 ;
 514       }
 515
 516     my $stop = time + $conf -> timeout + 10 ;
 517
 518     while ( $GET -> count () and time < $stop )
 519       { my @can_read = $GET -> can_read ( 0 ) ;
 520
 521         printf "wait %2d, probes %d, can_read %d\n",
 522           $stop - scalar time, $GET -> count (), scalar @can_read
 523             if Mirmon::verbose ;
 524
 525         for my $handle ( @can_read )
 526           { $GET -> remove ( $handle ) ;
 527             $m4h { $handle } -> finish_probe ( $handle ) ;
 528           }
 529
 530         sleep 10 ;
 531       }
 532
 533     for my $handle ( $GET -> handles () )
 534       { $m4h { $handle } -> update ( 0, 'hangs', undef ) ; }
 535   }
 536
 537 sub img_sf_cnt
 538   { my $self = shift ;
 539     my $prf  = shift ;
 540     my $cnt  = shift ;
 541     my $res ;
 542     if ( $prf eq 'x' )
 543       { sprintf
 544           ( '<IMG BORDER=1 SRC="%s/bar.gif" ALT="">'
 545           , $self -> conf -> icons
 546           ) x $cnt ;
 547       }
 548     else
 549      { sprintf '<IMG BORDER=1 SRC="%s/mm%s%02d.gif" ALT="">'
 550          , $self -> conf -> icons, $prf, $cnt ;
 551      }
 552   }
 553
 554 sub img_sf { my $self = shift ; $self -> img_sf_cnt ( $_[0], 1 ) ; }
 555
 556 sub show_hist
 557   { my $self = shift ;
 558     my $hst = shift ;
 559     if ( $hst =~ /-(.*)$/ ) { $hst = $1 ; }
 560     return '' unless $hst =~ m/^[sbfzx]+$/ ;
 561     if ( length $hst == $HIST and $hst =~ /^(s*b)s*$/ )
 562       { return $self -> img_sf_cnt ( 'sb',  length $1 ) ; }
 563     elsif ( length $hst == $HIST and $hst =~ /^(s*f)s*$/ )
 564       { return $self -> img_sf_cnt ( 'sf',  length $1 ) ; }
 565     elsif ( length $hst == $HIST and $hst =~ /^(s*b)fs*$/ )
 566       { return $self -> img_sf_cnt ( 'sbf', length $1 ) ; }
 567     my $res = '' ;
 568     my $cnt = 1 ;
 569     my $prf = substr $hst, 0, 1 ;
 570     $hst = substr $hst, 1 ;
 571     while ( $hst ne '' )
 572       { if ( substr ( $prf, 0, 1 ) eq substr ( $hst, 0, 1 ) )
 573           { $cnt ++ ;
 574             $hst = substr $hst, 1 ;
 575           }
 576         else
 577           { $res .= $self -> img_sf_cnt ( $prf, $cnt ) ;
 578             $prf = substr $hst, 0, 1 ;
 579             $hst = substr $hst, 1 ;
 580             $cnt = 1 ;
 581           }
 582       }
 583     $res .= $self -> img_sf_cnt ( $prf, $cnt ) if $cnt ;
 584     $res ;
 585   }
 586
 587 sub gen_histogram_probes
 588   { my $self = shift ;
 589     my $state = $self -> state ;
 590     my %tab = () ;
 591     my %bad = () ;
 592     my $res = '' ;
 593     my $s_cnt = 0 ;
 594     my $f_cnt = 0 ;
 595     my $hr_min ;
 596     my $hr_max ;
 597     for my $url ( keys %$state )
 598       { my $mirror = $state -> { $url } ;
 599         my $lprb = $mirror -> last_probe ;
 600         my $stat = $mirror -> last_status ;
 601         next if $lprb eq 'undef' ;
 602         my $hr = int ( ( $^T - $lprb ) / 3600 + 0.5 ) ;
 603         $hr_min = $hr if ! defined $hr_min or $hr < $hr_min ;
 604         $hr_max = $hr if ! defined $hr_max or $hr > $hr_max ;
 605         if ( $stat eq 'ok' )
 606           { $tab { $hr } ++ ; $s_cnt ++ ; }
 607         else
 608           { $bad { $hr } ++ ; $f_cnt ++ ; }
 609       }
 610     return BQ 'nothing yet' unless scalar keys %tab ;
 611
 612     $res = TR
 613       ( TH ( 'hours ago' )
 614       . TH ( 'succ' )
 615       . TH ( 'fail' )
 616       . TH sprintf
 617           ( '%s %s, %s %s'
 618           , $s_cnt , GRN ( 'successful' )
 619           , $f_cnt , RED ( 'failed' )
 620           )
 621       ) ;
 622
 623     my $max = 0 ;
 624     for my $x ( keys %tab )
 625       { my $tot = $tab { $x } + ( $bad { $x } || 0 ) ;
 626         $max = $tot if $max < $tot ;
 627       }
 628
 629     return BQ "nothing yet" unless $max ;
 630
 631     for my $hr ( $hr_min .. $hr_max )
 632       { my $x = $tab { $hr } || 0 ;
 633         my $y = $bad { $hr } || 0 ;
 634         my $n = int ( $x / $max * $HIST ) ;
 635         my $b = int ( $y / $max * $HIST ) ;
 636         $res .= TR
 637           ( TDr ( $hr )
 638           . TDr ( $x )
 639           . TDr ( $y )
 640           . TD
 641               ( ( $n ? $self -> img_sf_cnt ( 's', $n ) : '' )
 642               . ( $b ? $self -> img_sf_cnt ( 'f', $b ) : '' )
 643               . ( ( $n + $b ) ? '' : '&nbsp;' )
 644               )
 645           ) ;
 646       }
 647     return BQ TAB $res ;
 648   }
 649
 650 sub age_avg
 651   { my $self = shift ;
 652     my $state = $self -> state ;
 653     my @tab = () ;
 654     for my $url ( keys %$state )
 655       { my $time = $state -> { $url } -> age ;
 656         push @tab, $^T - $time if $time =~ /^\d+$/ ;
 657       }
 658     my $cnt = @tab ;
 659
 660     return undef if $cnt == 0 ;
 661
 662     @tab = sort { $a <=> $b } @tab ;
 663
 664     my $tot = 0 ;
 665     for my $age ( @tab ) { $tot += $age ; }
 666     my $mean = $tot / $cnt ;
 667
 668     my $median ;
 669     if ( $cnt == 1 )
 670       { $median = $tab [ 0 ] ; }
 671     elsif ( $cnt % 2 )
 672       { my $mid = int ( $#tab / 2 ) ;
 673         $median = ( $tab [ $mid ] + $tab [ $mid + 1 ] ) / 2 ;
 674       }
 675     else
 676       { my $mid = int ( $#tab / 2 ) ;
 677         $median = $tab [ $mid ] ;
 678       }
 679
 680     if ( @tab < 2 )
 681       { return $mean, $median, undef ; }
 682
 683     my $sum = 0 ;
 684     for my $age ( @tab )
 685       { $sum += ( $age - $mean ) ** 2 ; }
 686     my $stddev = sqrt ( $sum / ( $cnt - 1 ) ) ;
 687
 688     return $mean, $median, $stddev ;
 689   }
 690
 691 sub legend
 692   { my $self = shift ;
 693     my $conf = $self -> conf ;
 694     my $min_sync = $conf -> min_sync ;
 695     my $max_sync = $conf -> max_sync ;
 696     my $min_poll = $conf -> min_poll ;
 697     my $max_poll = $conf -> max_poll ;
 698
 699     return <<LEGENDA ;
 700 <H3>legend</H3>
 701
 702 <H4><I>project</I> site -- home</H4>
 703
 704 <BLOCKQUOTE>
 705 <B><I>project</I> site</B> is an url.
 706 The <B>href</B> is the href for the site in the list of mirrors,
 707 usually the root of the mirrored file tree.
 708 The <B>text</B> is the <I>site</I> of that url.
 709 <P>
 710 <B>home</B> (represented by the <B>@</B>-symbol) is an url
 711 pointing to the document root of the site. This pointer is
 712 useful if the <B><I>project</I> site</B> url is invalid,
 713 possibly because the mirror site moved the archive.
 714 </BLOCKQUOTE>
 715
 716 <H4>type</H4>
 717
 718 <BLOCKQUOTE>
 719 Indicates the type (<B>ftp</B> or <B>http</B>) of
 720 the <B><I>project</I> site</B> and <B>home</B> urls.
 721 </BLOCKQUOTE>
 722
 723 <H4>mirror age, daily stats</H4>
 724
 725 <BLOCKQUOTE>
 726 The <B>mirror age</B> is based upon the last successful probe.
 727 <P>
 728 Once a day the status of a mirror site is determined.
 729 The status (represented by a colored block) is appended
 730 to the <B>right</B> of the status history (<I>right</I>
 731 is <I>recent</I>). More precise, the status block is appended
 732 if the last status block was appended 24 (or more) hours ago.
 733 <P>The status of a mirror depends on its age and a few
 734 configuration parameters :
 735 <BLOCKQUOTE>
 736 <TABLE BORDER=1 CELLPADDING=5>
 737 <TR>
 738   <TH ROWSPAN=3>status</TH>
 739   <TH COLSPAN=4>age</TH>
 740 </TR>
 741 <TR>
 742   <TH COLSPAN=2 BGCOLOR=YELLOW>this project</TH>
 743   <TH COLSPAN=2 BGCOLOR=AQUA>in general</TH>
 744 </TR>
 745 <TR>
 746   <TH BGCOLOR=YELLOW>min</TH>
 747   <TH BGCOLOR=YELLOW>max</TH>
 748   <TH BGCOLOR=AQUA>min</TH>
 749   <TH BGCOLOR=AQUA>max</TH>
 750 </TR>
 751 <TR>
 752   <TH><FONT COLOR=GREEN>fresh</FONT></TH>
 753   <TD BGCOLOR=YELLOW ALIGN=CENTER>0</TD>
 754   <TD BGCOLOR=YELLOW ALIGN=CENTER>$min_sync + $max_poll</TD>
 755   <TD BGCOLOR=AQUA   ALIGN=CENTER>0</TD>
 756   <TD BGCOLOR=AQUA   ALIGN=CENTER>min_sync + max_poll</TD>
 757 </TR>
 758 <TR>
 759   <TH><FONT COLOR=BLUE>oldish</FONT></TH>
 760   <TD BGCOLOR=YELLOW ALIGN=CENTER>$min_sync + $max_poll</TD>
 761   <TD BGCOLOR=YELLOW ALIGN=CENTER>$max_sync + $max_poll</TD>
 762   <TD BGCOLOR=AQUA   ALIGN=CENTER>min_sync + max_poll</TD>
 763   <TD BGCOLOR=AQUA   ALIGN=CENTER>max_sync + max_poll</TD>
 764 </TR>
 765 <TR>
 766   <TH><FONT COLOR="RED">old</FONT></TH>
 767   <TD BGCOLOR=YELLOW ALIGN=CENTER>$max_sync + $max_poll</TD>
 768   <TD BGCOLOR=YELLOW ALIGN=CENTER>&infin;</TD>
 769   <TD BGCOLOR=AQUA   ALIGN=CENTER>max_sync + max_poll</TD>
 770   <TD BGCOLOR=AQUA   ALIGN=CENTER>&infin;</TD>
 771 </TR>
 772 <TR>
 773   <TH><FONT COLOR=BLACK>bad</FONT></TH>
 774   <TH COLSPAN=4 BGCOLOR=BLACK>
 775     <FONT COLOR=WHITE>the site or mirror tree was never found</FONT></TH>
 776 </TR>
 777 </TABLE>
 778 </BLOCKQUOTE>
 779 </BLOCKQUOTE>
 780
 781 <H4>last probe, probe stats</H4>
 782
 783 <BLOCKQUOTE>
 784 <B>Last probe</B> indicates when the last successful probe was made.
 785 <B>Probe stats</B> gives the probe history (<I>right</I> is <I>recent</I>).
 786 A probe is either a
 787 <FONT COLOR=GREEN><B>success</B></FONT> or a
 788 <FONT COLOR=RED><B>failure</B></FONT>.
 789 </BLOCKQUOTE>
 790
 791 <H4>last stat</H4>
 792
 793 <BLOCKQUOTE>
 794 <B>Last stat</B> gives the status of the last probe.
 795 </BLOCKQUOTE>
 796
 797 LEGENDA
 798   }
 799
 800 sub _ths
 801   { return '' unless my $ths = shift ;
 802     $ths == 1 ? TH '' : "<TH COLSPAN=$ths></TH>\n" ;
 803   }
 804
 805 sub gen_histogram
 806   { my $self  = shift ;
 807     my $where = shift ;
 808     my $conf  = $self -> conf ;
 809     my $state = $self -> state ;
 810
 811     return '' if $where ne $conf -> put_histo ;
 812
 813     my $MAX_H = $conf -> max_age1 ;
 814     my $MAX_h = 1 +
 815       ( ( 20 * 3600 <= $MAX_H and $MAX_H <= 36 * 3600 )
 816       ? int ( $MAX_H / 3600 )
 817       : 25
 818       ) ;
 819     my $MAX_O = $conf -> max_age2 ;
 820     my $MAX_o = int ( $MAX_O / 3600 + 0.5 ) ;
 821     my $H = 18 ;
 822     my %W   = ( 'old' => 1, 'ded' => 1, 'bad' => 1 ) ;
 823     my %Wmx = ( 'old' => 5, 'ded' => 3, 'bad' => 3 ) ;
 824     my %tab ;
 825     my %hst ;
 826     my $res ;
 827     for ( my $x = 0 ; $x < $MAX_h ; $x ++ ) { $tab { $x } = 0 ; }
 828     $tab { old } = 0 ; $tab { ded } = 0 ; $tab { bad } = 0 ;
 829     for my $url ( keys %$state )
 830       { my $time = $state -> { $url } -> age ;
 831         if ( $time =~ /^\d+$/ )
 832           { my $s  = $^T - $time ;
 833             my $hr = int ( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 ) ;
 834             if    ( $s <= $MAX_H ) { $tab { $hr  } ++ ; }
 835             elsif ( $s <= $MAX_O ) { $tab { old } ++ ; }
 836             else                   { $tab { ded } ++ ; }
 837           }
 838         else
 839           { $tab { bad } ++ ; }
 840       }
 841     my $max = 0 ;
 842     for ( grep ! exists $Wmx { $_ }, keys %tab )
 843       { $max = $tab { $_ } if $tab { $_ } > $max ; }
 844
 845     my %bad ;
 846
 847     for my $aux ( keys %Wmx )
 848       { $bad { $aux } = $tab { $aux } ;
 849         if ( $bad { $aux } > $max )
 850           { $W { $aux } = $Wmx { $aux } ;
 851             my $d = int ( $bad { $aux } / $W { $aux } ) ;
 852             for ( my $i = 1 ; $i < $W { $aux } ; $i++ )
 853               { $tab { $aux . $i } = $d ;
 854                 if ( $bad { $aux } % $Wmx { $aux } > $i )
 855                   { $tab { $aux . $i } ++ ;
 856                     $tab { $aux } -- ;
 857                   }
 858               }
 859             $tab { $aux } -= ( $W { $aux } - 1 ) * $d ;
 860             $max = $tab { $aux } if $max < $tab { $aux } ;
 861           }
 862       }
 863
 864 #   if ( $opt{v} )
 865 #     { for my $hr ( keys %tab )
 866 #         { printf "tab '%s' = '%s'\n", $hr, $tab { $hr } ; }
 867 #     }
 868
 869     return 'nothing yet' unless $max ;
 870     $H = $max if 8 <= $max and $max <= 26 ;
 871     for ( keys %tab )
 872       { $hst { $_ } = int ( $H * $tab { $_ } / $max + 0.5 ) ; }
 873     my @keys = sort { $a <=> $b } grep /^\d+$/, keys %hst ;
 874     my $tab_hr = 0 ;
 875     for my $hr ( @keys ) { $tab_hr += $tab { $hr } ; }
 876     push @keys
 877       , grep ( m/^old/, sort keys %tab )
 878       , grep ( m/^ded/, sort keys %tab )
 879       , grep ( m/^bad/, sort keys %tab )
 880       ;
 881     my $img_bar = sprintf '<IMG SRC="%s/bar.gif" ALT="" BORDER=0>'
 882       , $conf -> icons ;
 883     my %img = ( bar => $img_bar ) ;
 884     for my $col ( qw(s b f z) ) { $img { $col } = $self -> img_sf ( $col ) ; }
 885
 886     for ( my $h = $H ; $h > 0 ; $h -- )
 887       { $res .= "<TR>\n" ;
 888         $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"TOP\">&uarr;</TH>\n"
 889           if $h == $H ;
 890         $res .= sprintf '<TD ROWSPAN=%d ALIGN="CENTER">%s</TD>' . "\n"
 891           , $H-6, NSS ( $max ) if $h == $H - 3 ;
 892         $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"BOTTOM\">&darr;</TH>\n"
 893           if $h == 3 ;
 894         my $ths = 0 ;
 895         for my $x ( @keys )
 896           { my $col =
 897               ( ( $hst { $x } >= $h )
 898               ? ( $x =~ /^\d+$/
 899                 ? 's'
 900                 : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) )
 901                 )
 902               : ( ( $h == 1 and $hst { $x } == 0 ) ? 'bar' : '' )
 903               ) ;
 904             if ( $col )
 905               { $res .= _ths $ths ; $ths = 0 ; $res .= TH $img { $col } ; }
 906             else
 907               { $ths ++ ; }
 908           }
 909         $res .= _ths ( $ths ) . "</TR>\n" ;
 910       }
 911
 912     my $HR = '<HR SIZE=2 WIDTH="95%%" NOSHADE>' ;
 913
 914     $res .= "<TR>\n" ;
 915     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", 1 ;
 916     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $MAX_h ;
 917     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { old } ;
 918     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { ded } ;
 919     $res .= sprintf "<TD COLSPAN=%d>$HR</TD>\n", $W { bad } ;
 920     $res .= "</TR>\n" ;
 921
 922     $res .= "<TR>\n" ;
 923     $res .= '<TD ALIGN="CENTER">&nbsp;<B>age</B>&nbsp;&rarr;&nbsp;</TD>' ;
 924
 925     $res .= "<TH>|</TH>\n" ;
 926     $res .= sprintf
 927       ( '<TD COLSPAN=%d ALIGN="CENTER">'
 928       . '&larr;&nbsp; 0 &le; <B>age</B> &le; %s &nbsp;&rarr;'
 929       . "</TD>\n"
 930       , $MAX_h - 2, pr_interval ( $MAX_H )
 931       )
 932       ;
 933     $res .= "<TH>|</TH>\n" ;
 934     $res .= sprintf
 935       ( '<TD ALIGN="CENTER" COLSPAN=%d>'
 936       . '&nbsp;%sh&nbsp;&lt;&nbsp;%s&nbsp;&le;&nbsp;%sh&nbsp;'
 937       . "</TD>\n"
 938       , $W { old }, int($MAX_H/60/60) , BLD ( 'age' ), $MAX_o
 939       ) ;
 940     $res .= sprintf
 941       ( '<TD ALIGN="CENTER" COLSPAN=%d>'
 942       . '&nbsp;<FONT COLOR="RED">old</FONT>&nbsp;'
 943       . "</TD>\n"
 944       , $W { ded }
 945       ) ;
 946     $res .= sprintf
 947       ( '<TD ALIGN="CENTER" COLSPAN=%d>'
 948       . '&nbsp;<FONT COLOR="RED">bad</FONT>&nbsp;'
 949       . "</TD>\n"
 950       , $W { bad }
 951       ) ;
 952     $res .= "</TR>\n" ;
 953
 954     my $FRMT = '<TD ALIGN="CENTER" COLSPAN=%d>&nbsp;%s&nbsp;</TD>' ;
 955
 956     $res .= "<TR>\n" ;
 957     $res .= sprintf "$FRMT\n", 1,  NSS scalar keys %$state ;
 958     $res .= "<TH>|</TH>\n" ;
 959     $res .= sprintf "$FRMT\n", $MAX_h - 2, NSS $tab_hr ;
 960     $res .= "<TH>|</TH>\n" ;
 961     $res .= sprintf "$FRMT\n", $W { old }, NSS $bad { old } ;
 962     $res .= sprintf "$FRMT\n", $W { ded }, NSS $bad { ded } ;
 963     $res .= sprintf "$FRMT\n", $W { bad }, NSS $bad { bad } ;
 964     $res .= "</TR>\n" ;
 965
 966     $res = "<TABLE CELLSPACING=0 CELLPADDING=1 BORDER=0>\n$res\n</TABLE>\n" ;
 967     $res = sprintf "<TABLE CELLPADDING=5 BORDER=4>%s</TABLE>\n"
 968        , "<TR><TH>\n$res\n</TH></TR>" ;
 969     my $units = join ' '
 970       , $self -> img_sf ( 's' ) , $self -> img_sf ( 'b' )
 971       , $self -> img_sf ( 'f' ) , $self -> img_sf ( 'z' )
 972       ;
 973     if ( $max == $H )
 974       { $res .= sprintf "<BR>units %s represent one mirror site.\n"
 975           , $units ;
 976       }
 977     else
 978       { $res .= sprintf "<BR>each %s unit represents %s mirror sites.\n"
 979           , $units, sprintf ( "%.1f", $max / $H ) ;
 980       }
 981     return H2 ( NAM 'age-histogram', 'age histogram' )
 982       . BQ $res ;
 983   }
 984
 985 sub gen_page
 986   { my $self    = shift ;
 987     my $get     = shift ;
 988     my $VERSION = shift ;
 989     my $conf  = $self -> conf ;
 990     my $PPP   = $conf -> web_page ;
 991     my $state = $self -> state ;
 992     my $CCS   = $self -> regions ;
 993     my $TMP = "$PPP.tmp" ;
 994     my %tab ;
 995     my $refs ;
 996
 997     for my $url ( keys %$state )
 998       { my $mirror = $state -> { $url } ;
 999         my $reg = $mirror -> region ;
1000         push @{ $tab { $reg } }, $mirror ;
1001       }
1002
1003     my $bad = 0 ; my $old = 0 ; my $unr = 0 ;
1004     my %stats ;
1005     my @stats ;
1006     my $ok = 0 ;
1007
1008     for my $url ( keys %$state )
1009       { my $mirror = $state -> { $url } ;
1010         my $time = $mirror -> age ;
1011         my $stat = $mirror -> last_status ;
1012         my $vrfy = $mirror -> last_ok_probe ;
1013         if ( $stat eq 'ok' ) { $ok ++ ; } else { $stats { $stat } ++ ; }
1014         if ( $time eq 'undef' )
1015           { $bad ++ ; }
1016         elsif ( 'f' eq $conf -> age_code ( $time ) )
1017           { $old ++ ; }
1018         if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - $conf -> max_vrfy )
1019           { $unr ++ ; }
1020       }
1021
1022     my $STAT = sprintf
1023         "%d bad -- %d older than %s -- %s unreachable for more than %s"
1024       , $bad
1025       , $old
1026       , pr_interval ( $conf -> max_age2 )
1027       , $unr
1028       , pr_interval ( $conf -> max_vrfy )
1029       ;
1030
1031     my $PROB = 'last probes : ' ;
1032     push @stats, "$ok were ok" if $ok ;
1033     for my $stat ( sort keys %stats )
1034       { ( my $txt = $stat ) =~ s/_/ /g ;
1035         push @stats, sprintf "%s had %s" , $stats { $stat } , RED $txt ;
1036       }
1037     $PROB .= join ', ', @stats ;
1038
1039     my ( $mean, $median, $stddev ) = $self -> age_avg ;
1040     my $AVGS = "mean mirror age is " ;
1041     unless ( defined $mean )
1042        { $AVGS = "<I>undefined</I>" ; }
1043     else
1044        { $AVGS .= sprintf "%s", pr_interval $mean ;
1045          if ( defined $stddev )
1046            { $AVGS .= sprintf ", std_dev %s", pr_interval $stddev ; }
1047          $AVGS .= sprintf ", median %s", pr_interval $median ;
1048        }
1049
1050     for my $reg ( sort keys %tab )
1051       { $refs .= sprintf "&nbsp;%s&nbsp;\n"
1052           , URL "#$reg", "<FONT SIZE=\"+1\">$reg</FONT>"
1053           ;
1054       }
1055
1056     my $COLS = 5 ;
1057     my $NAME = $conf -> project_name ;
1058     my $LOGO = $conf -> project_logo
1059       ? URL
1060           ( $conf -> project_url
1061           , sprintf
1062               ( '<IMG SRC="%s" ALT="%s" ALIGN="RIGHT" BORDER=0>'
1063               , $conf -> project_logo
1064               , $conf -> project_name
1065               )
1066           )
1067       : ''
1068       ;
1069     my $HEAD = $conf -> htm_head . "\n" ;
1070     my $HTOP = $conf -> htm_top  . "\n" ;
1071     my $FOOT = $conf -> htm_foot . "\n" ;
1072     my $TITL = URL $conf -> project_url, $NAME ;
1073     my $EXPD = Base::exp_date ;
1074     my $DATE = scalar gmtime $^T ;
1075     my $LAST = scalar gmtime ( $get ? $^T : ( stat $conf -> state ) [9] ) ;
1076
1077     my $histo_top = $self -> gen_histogram ( 'top' ) ;
1078     my $histo_bot = $self -> gen_histogram ( 'bottom' ) ;
1079
1080     open PPP, ">$TMP" or die "can't write $TMP ($!)" ;
1081     my $prev_select = select PPP ;
1082
1083     my $attr1 = "COLSPAN=$COLS BGCOLOR=LIME" ;
1084     my $attr2 = 'BGCOLOR=AQUA' ;
1085     my $attr3 = "COLSPAN=$COLS BGCOLOR=YELLOW" ;
1086
1087     my $num_mirrors = scalar keys %$state ;
1088     my $num_regions = scalar keys %tab ;
1089
1090     print <<HEAD ;
1091 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
1092 <HTML>
1093 <HEAD>
1094 <TITLE>the status of $NAME mirrors</TITLE>
1095 <META HTTP-EQUIV="content-type" CONTENT="text/html; charset=utf-8">
1096 <META HTTP-EQUIV=refresh CONTENT=3600>
1097 <META HTTP-EQUIV=Expires CONTENT=\"$EXPD\">
1098 $HEAD
1099 </HEAD>
1100 <BODY BGCOLOR=\"#FFFFFF\">
1101 $LOGO
1102 <H2>the status of $TITL mirrors</H2>
1103 <TABLE BORDER=0 CELLPADDING=2>
1104 <TR><TD>date</TD><TD>:</TD><TD>$DATE (UTC)</TD></TR>
1105 <TR><TD>last&nbsp;check</TD>
1106   <TD>:</TD>
1107   <TD>$LAST (UTC)</TD>
1108 </TR>
1109 </TABLE>
1110 $HTOP
1111 $histo_top
1112 <H2>regions</H2>
1113 <BLOCKQUOTE><CENTER>\n$refs\n</CENTER></BLOCKQUOTE>
1114 <H2>report</H2>
1115 <BLOCKQUOTE>
1116 <TABLE BORDER=2 CELLPADDING=5>
1117 <TR><TH $attr1>$num_mirrors sites in $num_regions regions</TH></TR>
1118 <TR><TH $attr1>$STAT</TH></TR>
1119 <TR><TH $attr1>$PROB</TH></TR>
1120 <TR><TH $attr1>$AVGS</TH></TR>
1121 <TR>
1122   <TH $attr2>$NAME site -- home</TH>
1123   <TH $attr2>type</TH>
1124   <TH $attr2>mirror age,<BR>daily stats</TH>
1125   <TH $attr2>last probe,<BR>probe stats</TH>
1126   <TH $attr2>last stat</TH>
1127 </TR>
1128 HEAD
1129
1130     for my $reg
1131       ( sort { _cmp_ccs $CCS, $a, $b } keys %tab )
1132 #      { ( $CCS -> { $a } ? lc ( $CCS -> { $a } ) : $a )
1133 #    cmp ( $CCS -> { $b } ? lc ( $CCS -> { $b } ) : $b )
1134 #      } keys %tab
1135 #     )
1136       { my $mirrors = $tab { $reg } ;
1137
1138         my $ccs = exists $CCS -> { $reg } ? $CCS -> { $reg } : $reg ;
1139         $ccs = NAM $reg,
1140           ( scalar @{ $mirrors } > 6
1141           ? sprintf "%s&nbsp;&nbsp;-&nbsp;&nbsp;%d sites"
1142               , $ccs, scalar @{ $mirrors }
1143           : $ccs
1144           ) ;
1145         printf "<TR><TH $attr3>$ccs</TH></TR>\n" ;
1146
1147         for my $mirror ( sort { $a -> cmp ( $b ) } @$mirrors )
1148           { print "<TR>\n" ;
1149             printf "  <TD ALIGN=RIGHT>%s&nbsp;&nbsp;%s</TD>\n  <TD>%s</TD>\n"
1150               , $mirror -> url_site
1151               , $mirror -> url_home
1152               , $mirror -> type
1153               ;
1154
1155             my ( $url, $time, $stat, $vrfy, $hstp, $hsts ) =
1156               $mirror -> as_list ;
1157             my $pr_time = $time =~ /^\d+$/
1158               ? pr_diff $time, $^T - $conf -> max_age2 : '&nbsp;' ;
1159             my $pr_last = $vrfy =~ /^\d+$/
1160               ? pr_diff $vrfy, $^T - $conf -> max_vrfy : '&nbsp;' ;
1161             my $pr_hstp = $self -> show_hist ( $hstp ) ;
1162             my $pr_hsts = $self -> show_hist ( $hsts ) ;
1163
1164             if ( $stat ne 'ok' ) { $stat =~ s/_/ /g ; $stat = RED $stat ; }
1165             printf "  <TD ALIGN=RIGHT>%s<BR>%s</TD>\n" , $pr_time, $pr_hsts ;
1166             printf "  <TD ALIGN=RIGHT>%s<BR>%s</TD>\n" , $pr_last, $pr_hstp ;
1167             printf "  <TD>%s</TD>\n", $stat ;
1168             print "</TR>\n" ;
1169           }
1170       }
1171
1172     my $legend = $self -> legend ;
1173     my $probes = $self -> gen_histogram_probes ;
1174     my $mir_img = sprintf
1175       '<IMG BORDER=2 ALT=mirmon SRC="%s/mirmon.gif">' , $conf -> icons ;
1176
1177     print <<TAIL ;
1178 </TABLE>
1179 </BLOCKQUOTE>
1180 $histo_bot
1181 $legend
1182 <H3>probe results</H3>
1183 $probes
1184 <H3>software</H3>
1185 <BLOCKQUOTE>
1186 <TABLE>
1187 <TR>
1188   <TH><A HREF=\"$HOME\">$mir_img</A></TH>
1189   <TD>$VERSION</TD>
1190 </TR>
1191 </TABLE>
1192 </BLOCKQUOTE>
1193 $FOOT
1194 </BODY>
1195 </HTML>
1196 TAIL
1197
1198     select $prev_select ;
1199
1200     if ( print PPP "\n" )
1201       { close PPP ;
1202         if ( -z $TMP )
1203           { warn "wrote empty html file; keeping previous version" ; }
1204         else
1205           { rename $TMP, $PPP or die "can't rename $TMP, $PPP ($!)" ; }
1206       }
1207     else
1208       { die "can't print to $TMP ($!)" ; }
1209   }
1210
1211 package Mirmon::Conf ; #############################################
1212
1213 BEGIN { use base 'Base' ; Base -> import () ; }
1214
1215 our %CNF_defaults =
1216   ( project_logo => ''
1217   , timeout      => $DEF_TIMEOUT
1218   , max_probes   => 25
1219   , min_poll     => '1h'
1220   , max_poll     => '4h'
1221   , min_sync     => '1d'
1222   , max_sync     => '2d'
1223   , list_style   => 'plain'
1224   , put_histo    => 'top'
1225   , randomize    => 1
1226   , add_slash    => 1
1227   , htm_top      => ''
1228   , htm_foot     => ''
1229   , htm_head     => ''
1230   , always_get   => ''
1231   ) ;
1232
1233 our @REQ_KEYS =
1234   qw( web_page state countries mirror_list probe
1235       project_name project_url icons
1236     ) ;
1237 our %CNF_KEYS ;
1238 for ( @REQ_KEYS, keys %CNF_defaults ) { $CNF_KEYS { $_ } ++ ; }
1239
1240 my @LIST_STYLE = qw(plain apache) ;
1241 my @PUT_HGRAM  = qw(top bottom nowhere) ;
1242
1243 eval Base -> mk_methods ( keys %CNF_KEYS, qw(root site_url) ) ;
1244
1245 sub get_xtr
1246   { my $self = shift ;
1247     my $reg  = shift ;
1248     scalar grep { $_ eq $reg } split ' ', $self -> always_get ;
1249   }
1250
1251 sub new
1252   { my $self = shift ;
1253     my $FILE = shift ;
1254     my $res = bless { %CNF_defaults }, $self ;
1255     $res -> root ( $FILE ) ;
1256     $res -> site_url ( {} ) ;
1257     $res -> get_conf () ;
1258   }
1259
1260 sub get_conf
1261   { my $self = shift ;
1262     my $FILE = ( @_ ? shift : $self -> root ) ;
1263
1264     if ( grep $_ eq $FILE,  @{ $self -> {_include} } )
1265       { die "already included : '$FILE'" ; }
1266     else
1267       { push @{ $self -> {_include} }, $FILE ; }
1268
1269     open FILE, $FILE or die "can't open '$FILE' ($!)" ;
1270     my $CONF = join "\n", grep /./, <FILE> ;
1271     close FILE ;
1272
1273     $CONF =~ s/\t/ /g ;           # replace tabs
1274     $CONF =~ s/^[+ ]+// ;         # delete leading space, plus
1275     $CONF =~ s/\n\n\s+/ /g ;      # glue continuation lines
1276     $CONF =~ s/\n\n\+\s+//g ;     # glue concatenation lines
1277     $CONF =~ s/\n\n\./\n/g ;      # glue concatenation lines
1278
1279     chop $CONF ;
1280     print "--$CONF--\n" if Mirmon::debug ;
1281     for ( grep ! /^#/, split /\n\n/, $CONF )
1282       { my ($key,$val) = split ' ', $_, 2 ;
1283         $val = '' unless defined $val ;
1284         print "conf '$FILE' : key '$key', val '$val'\n" if Mirmon::debug ;
1285         if ( exists $CNF_KEYS { $key } )
1286           { $self -> $key ( $val ) ; }
1287         elsif ( $key eq 'site_url' )
1288           { my ( $site, $url ) = split ' ' , $val ;
1289             $url .= '/' if $self -> add_slash and $url !~ m!/$! ;
1290             $self -> site_url -> { $site } = $url ;
1291 #           printf "config : for site '%s' use instead\n   '%s'\n",
1292 #             $site, $url if Mirmon::verbose ;
1293           }
1294         elsif ( $key eq 'no_add_slash' )
1295           { $self -> add_slash ( 0 ) ; }
1296         elsif ( $key eq 'no_randomize' )
1297           { $self -> randomize ( 0 ) ; }
1298         elsif ( $key eq 'show' )
1299           { $self -> show_conf if Mirmon::verbose ; }
1300         elsif ( $key eq 'exit' )
1301           { die 'exit per config directive' ; }
1302         elsif ( $key eq 'include' )
1303           { $self -> get_conf ( $val ) ; }
1304         elsif ( $key eq 'env' )
1305           { my ( $x, $y ) = split ' ' , $val ;
1306             $ENV { $x } = $y ;
1307             printf "config : setenv '%s'\n   '%s'\n", $x, $y
1308               if Mirmon::verbose ;
1309           }
1310         else
1311           { $self -> show_conf ;
1312             die "unknown keyword '$key' (value '$val')\n" ;
1313           }
1314       }
1315     my $err = $self -> check ;
1316     die $err if $err ;
1317     $self ;
1318   }
1319
1320 sub check
1321   { my $self = shift ;
1322     my $err = '' ;
1323     for my $key ( @REQ_KEYS )
1324       { unless ( exists $self -> { $key } )
1325           { $err .= "error: missing config for '$key'\n" ; }
1326       }
1327     for my $key ( qw(min_poll max_poll max_sync min_sync) )
1328       { my $max = $self -> $key ;
1329         unless ( $max =~ /$TIM_PAT/o )
1330           { $err .= "error: bad timespec for $key ($max)\n" ; }
1331       }
1332     unless ( grep $self -> { list_style } eq $_, @LIST_STYLE )
1333       { $err .= sprintf "error: unknown 'list_style' '%s'\n",
1334           $self -> list_style ;
1335       }
1336     unless ( grep $self -> put_histo eq $_, @PUT_HGRAM )
1337       { $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n",
1338           $self -> put_histo ;
1339       }
1340     $err ;
1341   }
1342
1343 sub show_conf
1344   { my $self = shift ;
1345     print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n" ;
1346     for my $key ( sort keys %$self )
1347       { next if $key =~ m/^_/ ;
1348         my $val = $self -> { $key } ;
1349         print "show_conf : $key = '$val'\n" ;
1350       }
1351     for my $key ( sort keys %{ $self -> site_url } )
1352       { printf "show_conf : for site '%s' use instead\n   '%s'\n"
1353           , $key, $self -> site_url -> { $key } if Mirmon::verbose ;
1354       }
1355     printf "show_conf : included '%s'\n"
1356       , join "', '", @{ $self -> {_include} } ;
1357     print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" ;
1358   }
1359
1360 sub max_age1
1361   { my $self = shift ;
1362     ( s4tim $self -> min_sync ) + ( s4tim $self -> max_poll ) ;
1363   }
1364
1365 sub max_age2
1366   { my $self = shift ;
1367     ( s4tim $self -> max_sync ) + ( s4tim $self -> max_poll ) ;
1368   }
1369
1370 sub max_vrfy
1371   { my $self = shift ;
1372     ( s4tim $self -> min_poll ) + ( s4tim $self -> max_poll ) ;
1373   }
1374
1375 sub age_code
1376   { my $self = shift ;
1377     my $time = shift ;
1378     return 'z' unless $time =~ /^\d+$/ ;
1379     return
1380       ( ( aprx_ge ( $time, $^T - $self -> max_age1 ) )
1381       ? 's'
1382       : ( aprx_ge ( $time, $^T - $self -> max_age2 ) ? 'b' : 'f' )
1383       ) ;
1384   }
1385
1386 package Mirmon::Mirror ; ###########################################
1387
1388 BEGIN { use base 'Base' ; Base -> import () ; }
1389
1390 use IO::Pipe ;
1391
1392 my @FIELDS =
1393   qw(url age last_status last_ok_probe probe_history state_history last_probe) ;
1394
1395 eval Base -> mk_methods ( @FIELDS, qw(mirmon region mail) ) ;
1396
1397 sub state_history_time
1398   { my $self = shift ;
1399     my $res = ( split /-/, $self -> state_history ) [ 0 ] ;
1400     $res ;
1401   }
1402
1403 sub state_history_hist
1404   { my $self = shift ;
1405     my $res = ( split /-/, $self -> state_history ) [ 1 ] ;
1406     $res ;
1407   }
1408
1409 sub _parse
1410   { my $self = shift ;
1411     my $url  = $self -> url ;
1412     my ( $type, $site, $home, $path ) ;
1413     if ( $url =~ m!^(ftp|https?|rsync)://([^/:]+)(:\d+)?/! )
1414       { $type = $1 ; $site = $2 ; $home = $& ; $path = $' ; }
1415     else
1416       { warn "can't parse url ($url)" ; }
1417     return $type, $site, $home, $path ;
1418   }
1419
1420 sub type { my $self = shift ; ( $self -> _parse ) [ 0 ] ; }
1421 sub site { my $self = shift ; ( $self -> _parse ) [ 1 ] ; }
1422 sub home { my $self = shift ; ( $self -> _parse ) [ 2 ] ; }
1423 sub path { my $self = shift ; ( $self -> _parse ) [ 3 ] ; }
1424
1425 sub age_in_days
1426   { my $self = shift ;
1427     my $res = 'undef' ;
1428     my $age = $self -> age ;
1429     if ( $age eq 'undef' )
1430       { $res = length $self -> state_history_hist
1431           if $self -> last_probe ne 'undef' ;
1432       }
1433     else
1434       { $res = ( $^T - $age ) / 24 / 60 / 60 ; }
1435     $res ;
1436   }
1437
1438 sub init
1439   { my $self   = shift ;
1440     my $mirmon = shift ;
1441     my $url    = shift ;
1442     my $res = bless { mirmon => $mirmon }, $self ;
1443     @{ $res } { @FIELDS } = ( 'undef' ) x scalar @FIELDS ;
1444     $res -> url ( $url ) ;
1445     $res -> probe_history ( '' ) ;
1446     $res -> state_history ( "$^T-z" ) ;
1447     $res -> mail ( '' ) ;
1448     $res ;
1449   }
1450
1451 sub new
1452   { my $self   = shift ;
1453     my $mirmon = shift ;
1454     my $line   = shift ;
1455     my $res = bless { mirmon => $mirmon }, $self ;
1456     @{ $res } { @FIELDS } = split ' ', $line ;
1457     $res -> mail ( '' ) ;
1458     $res ;
1459   }
1460
1461 sub update
1462   { my $self = shift ;
1463     my $succ = shift ;
1464     my $stat = shift ;
1465     my $time = shift ;
1466     my $probe_hist = $self -> probe_history ;
1467     if ( $succ )
1468       { $self -> age ( $time ) ;
1469         $self -> last_ok_probe ( $^T ) ;
1470         $probe_hist .= 's' ;
1471       }
1472     else
1473       { $probe_hist .= 'f' ;
1474         $time = $self -> age ;
1475       }
1476
1477     my $h = $self -> state_history_hist ;
1478     my $t = $self -> state_history_time ;
1479
1480     if ( aprx_ge ( $^T - $t, $HIST_DELTA ) )
1481       { my $n = int ( ( $^T - $t ) / $HIST_DELTA ) ;
1482         $h .= 'x' x ( $n - 1 ) ;
1483         $t = ( $n == 1 ? $t + $HIST_DELTA : $^T ) ;
1484       }
1485     else
1486       { chop $h ; }
1487     $h .= $self -> mirmon -> conf -> age_code ( $time ) ;
1488     $h = substr $h, - $HIST ;
1489     $h =~ s/^x+// ;
1490
1491     $self -> last_status ( $stat ) ;
1492     $self -> probe_history ( substr $probe_hist, - $HIST ) ;
1493     $self -> last_probe ( $^T ) ;
1494     $self -> state_history ( "$t-$h" ) ;
1495   }
1496
1497 sub as_list { my $self = shift ; @{ $self } { @FIELDS } ; }
1498 sub state { my $self = shift ; join ' ', $self -> as_list ; }
1499
1500 sub start_probe
1501   { my $self = shift ;
1502     my $conf = $self -> mirmon -> conf ;
1503     my $probe = $conf -> probe ;
1504     my $timeout = $conf -> timeout ;
1505     $probe =~ s/%TIMEOUT%/$timeout/g ;
1506     my $url = $self -> url ;
1507     my $new = $conf -> site_url -> { $self -> site } ;
1508     if ( defined $new )
1509       { printf "*** site_url : site %s\n  -> url %s\n"
1510           , $self -> site, $new if Mirmon::verbose ;
1511         $url = $new ;
1512       }
1513     $probe =~ s/%URL%/$url/g ;
1514     my $pipe = new IO::Pipe ;
1515     my $handle = $pipe -> reader ( split ' ', $probe ) ;
1516     if ( $handle )
1517       { $pipe -> blocking ( 0 ) ; }
1518     else
1519       { die "start_probe : no pipe for $url" ; }
1520     printf "start %s\n", $url if Mirmon::verbose ;
1521     printf "  %s\n", $probe if Mirmon::debug ;
1522     $handle ;
1523   }
1524
1525 sub finish_probe
1526   { my $self   = shift ;
1527     my $handle = shift ;
1528     my $res ;
1529     my $succ = 0 ;
1530     my $stat ;
1531     my $time ;
1532
1533     $handle -> blocking ( 1 ) ;
1534     if ( $handle -> eof () )
1535       { printf "finish eof %s\n", $self -> url if Mirmon::verbose ; }
1536     else
1537       { $res = $handle -> getline () ; }
1538     $handle -> flush ;
1539     $handle -> close ;
1540
1541     unless ( defined $res )
1542       { $stat = 'no_time' ; }
1543     elsif ( $res =~ /^\s*$/ )
1544       { $stat = 'empty' ; }
1545     else
1546       { $res = ( split ' ', $res ) [ 0 ] ;
1547
1548         if ( $res !~ /^\d+$/ )
1549           { $res =~ s/ /_/g ;
1550             $res = Base::htmlquote $res ;
1551             $res = substr ( $res, 0, 15 ) . '..' if length $res > 15 ;
1552             $stat = "'$res'" ;
1553           }
1554         else
1555           { $succ = 1 ; $stat = 'ok' ; $time = $res ; }
1556       }
1557
1558     printf "finish %s\n  succ(%s) stat(%s) time(%s)\n"
1559       , $self -> url
1560       , $succ
1561       , $stat
1562       , ( defined $time ? $time : 'undef' )
1563         if Mirmon::verbose ;
1564
1565     $self -> update ( $succ, $stat, $time ) ;
1566   }
1567
1568 sub revdom { my $dom = shift ; join '.', reverse split /\./, $dom ; }
1569
1570 sub cmp
1571   { my $a = shift ;
1572     my $b = shift ;
1573     ( revdom $a -> site ) cmp ( revdom $b -> site )
1574     or
1575     ( $a -> type cmp $b -> type )
1576     ;
1577   }
1578
1579 sub _url
1580   { my $hrf = shift ;
1581     my $txt = shift ;
1582     $hrf =~ /^rsync/ ? $txt : URL $hrf, $txt ;
1583   }
1584
1585 sub url_site
1586   { my $self = shift ;
1587     my $type = $self -> type ;
1588     if ( $type eq 'rsync' )
1589       { my $path = $self -> path ;
1590         chop $path if $path =~ m!/$! ;
1591         sprintf '%s::%s', $self -> site , $path ;
1592       }
1593     else
1594       { URL $self -> url , $self -> site ; }
1595   }
1596
1597 sub url_home
1598   { my $self = shift ;
1599     my $type = $self -> type ;
1600     if ( $type eq 'rsync' )
1601       { '@' ; }
1602     else
1603       { URL $self -> home, '@' ; }
1604   }
1605
1606 =pod
1607
1608 =head1 NAME
1609
1610 Mirmon - OO interface for mirmon objects
1611
1612 =head1 SYNOPSIS
1613
1614   use Mirmon ;
1615
1616   $m = Mirmon -> new ( [ $path-to-config ] )
1617
1618   $conf  = $m -> conf  ; # a Mirmon::Conf object
1619   $state = $m -> state ; # the mirmon state
1620
1621   for my $url ( keys %$state )
1622     { $mirror = $state -> { $url } ; # a Mirmon::Mirror object
1623       $mail = $mirror -> mail ;      # contact address
1624       $mirror -> age ( time ) ;      # set mirror age
1625     }
1626
1627 Many class and object methods can be used to get or set attributes :
1628
1629   $object -> attribute           # get an atttibute
1630   $object -> attribute ( $attr ) # set an atttibute
1631
1632 =head1 Mirmon class methods
1633
1634 =over 4
1635
1636 =item B<new ( [$path] )>
1637
1638 Create a Mirmon object from a config file found in $path,
1639 or (by default) in the default list of possible config files.
1640 Related objects (config, state) are created and initialised.
1641
1642 =item verbosity
1643
1644 Mirmon always reports errors. Normally it only reports
1645 changes (inserts/deletes) found in the mirror_list ;
1646 in I<quiet> mode, it doesn't. In I<verbose> mode, it
1647 reports progress: the startup and finishing of probes.
1648
1649   Mirmon::verbose ( [ $bool ] ) # get/set verbose
1650   Mirmon::quiet   ( [ $bool ] ) # get/set quiet
1651   Mirmon::debug   ( [ $bool ] ) # get/set debug
1652
1653 =back
1654
1655 =head1 Mirmon object methods
1656
1657 =over 4
1658
1659 =item B<conf>
1660
1661 Returns Mirmon's Mirmon::Conf object.
1662
1663 =item B<state>
1664
1665 Returns a hashref C<< { url => mirror, ... } >>,
1666 where I<url> is as specified in the mirror list
1667 and I<mirror> is a Mirmon::Mirror object.
1668
1669 =item B<regions>
1670
1671 Returns a hashref C<< { country_code =E<gt> country_name, ... } >>.
1672
1673 =item B<config_list>
1674
1675 Returns the list of default locations for config files.
1676
1677 =item B<get_dates ( $get [, $URL] )>
1678
1679 Probes all mirrors if $get is C<all> ; or a subset if $get is C<update> ;
1680 or only I<$URL> if $get is C<url>.
1681
1682 =back
1683
1684 =head1 Mirmon::Conf object methods
1685
1686 A Mirmon::Conf object represents a mirmon conguration.
1687 It is normaly created by Mirmon::new().
1688 A specified (or default) config file is read and interpreted.
1689
1690 =over 4
1691
1692 =item attribute methods
1693
1694 For every config file entry, there is an attribute method :
1695 B<web_page>, B<state>, B<countries>, B<mirror_list>, B<probe>,
1696 B<project_name>, B<project_url>, B<icons>, B<project_logo>,
1697 B<timeout>, B<max_probes>, B<min_poll>, B<max_poll>, B<min_sync>,
1698 B<max_sync>, B<list_style>, B<put_histo>, B<randomize>, B<add_slash>.
1699
1700 =item B<root>
1701
1702 Returns the file name of (the root of) the configuration file(s).
1703
1704 =item B<site_url>
1705
1706 Returns a hashref C<< { site => url, ... } >>,
1707 as specified in the mirmon config file.
1708
1709 =back
1710
1711 =head1 Mirmon::Mirror object methods
1712
1713 A Mirmon::Mirror object represents the last known state of a mirror.
1714 It is normaly created by Mirmon::new() from the state file,
1715 as specified in the mirmon config file.
1716 Mirmon::Mirror objects can be used to probe mirrors.
1717
1718 =head2 attribute methods
1719
1720 =over 4
1721
1722 =item B<url>
1723
1724 The url as given in the mirror list.
1725
1726 =item B<age>
1727
1728 The mirror's timestamp found by the last successful probe,
1729 or 'undef' if no probe was ever successful.
1730
1731 =item B<last_status>
1732
1733 The status of the last probe, or 'undef' if the mirror was never probed.
1734
1735 =item B<last_ok_probe>
1736
1737 The timestamp of the last successful probe or 'undef'
1738 if the mirror was never successfully probed.
1739
1740 =item B<probe_history>
1741
1742 The probe history is a list of 's' (for success) and 'f' (for failure)
1743 characters indicating the result of the probe. New results are appended
1744 whenever the mirror is probed.
1745
1746 =item B<state_history>
1747
1748 The state history consists of a timestamp, a '-' char, and a list of
1749 chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old),
1750 'z' (bad) or 'x' (skip).
1751 The timestamp indicates when the state history was last updated.
1752 The current status of the mirror is determined by the mirror's age and
1753 a few configuration parameters (min_sync, max_sync, max_poll).
1754 The state history is updated when the mirror is probed.
1755 If the last update of the history was less than 24 hours ago,
1756 the last status is replaced by the current status.
1757 If the last update of the history was more than 24 hours ago,
1758 the current status is appended to the history.
1759 One or more 'skip's are inserted, if the timestamp is two or more days old
1760 (when mirmon hasn't run for more than two days).
1761
1762 =item B<last_probe>
1763
1764 The timestamp of the last probe, or 'undef' if the mirror was never probed.
1765
1766 =back
1767
1768 =head2 object methods
1769
1770 =over 4
1771
1772 =item B<mirmon>
1773
1774 Returns the parent Mirmon object.
1775
1776 =item B<state_history_time>
1777
1778 Returns the I<time> part of the state_history attribute.
1779
1780 =item B<state_history_hist>
1781
1782 Returns the I<history> part of the state_history attribute.
1783
1784 =item B<type>, B<site>, B<home>
1785
1786 For an url like I<ftp://www.some.org/path/to/home>,
1787 the B<type> is I<ftp>,
1788 the B<site> is I<www.some.org>,
1789 and B<home> is I<ftp://www.some.org/>.
1790
1791 =item B<age_in_days>
1792
1793 Returns the mirror's age (in fractional days), based on the mirror's
1794 timestamp as found by the last successful probe ; or based on the
1795 length of the state history if no probe was ever successful.
1796 Returns 'undef' if the mirror was never probed.
1797
1798 =item B<mail>
1799
1800 Returns the mirror's contact address as specified in the mirror list.
1801
1802 =item B<region>
1803
1804 Returns the mirror's country code as specified in the mirror list.
1805
1806 =item B<start_probe>
1807
1808 Start a probe for the mirror in non-blocking mode ;
1809 returns the associated (IO::Handle) file handle.
1810 The caller must maintain an association between
1811 the handles and the mirror objects.
1812
1813 =item B<finish_probe ( $handle )>
1814
1815 Sets the (IO::Handle) B<$handle> to blocking IO ;
1816 reads a result from the handle,
1817 and updates the state of the mirror.
1818
1819 =back
1820
1821 =head1 SEE ALSO
1822
1823 =begin html
1824
1825 <p>
1826 <a href="mirmon.html">mirmon(1)</a>
1827 </p>
1828
1829 =end html
1830
1831 =begin man
1832
1833 mirmon(1)
1834
1835 =end man
1836
1837 =head1 AUTHOR
1838
1839 =begin html
1840
1841   <p>
1842   &copy; 2003-2014
1843   <a href="http://www.staff.science.uu.nl/~penni101/">Henk P. Penning</a>,
1844   <a href="http://www.uu.nl/faculty/science/EN/">Faculty of Science</a>,
1845   <a href="http://www.uu.nl/">Utrecht University</a>
1846   <br />
1847   mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp ;
1848   <a href="http://validator.w3.org/check?uri=referer">verify html</a>
1849   </p>
1850
1851 =end html
1852
1853 =begin man
1854
1855   (c) 2003-2014 Henk P. Penning
1856   Faculty of Science, Utrecht University
1857   http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
1858   mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp
1859
1860 =end man
1861
1862 =begin text
1863
1864   (c) 2003-2014 Henk P. Penning
1865   Faculty of Science, Utrecht University
1866   http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
1867   mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp
1868
1869 =end text
1870
1871 =cut
1872
1873 package main ; #####################################################
1874
1875 use IO::Pipe ;
1876 use IO::Select ;
1877 use Net::hostent ;
1878
1879 my $VERSION = Base::Version . ' - Fri Aug 15 12:26:55 2014 - henkp' ;
1880 my $DEF_CNF = join ', ', Mirmon -> config_list ;
1881 my $TIMEOUT = Base::DEF_TIMEOUT ;
1882
1883 my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
1884 my $Usage = <<USAGE ;
1885 Usage: $prog [-v] [-q] [-t timeout] [-c conf] [-get all|update|url <url>]
1886 option v   : be verbose
1887 option q   : be quiet
1888 option t   : set timeout ; default $TIMEOUT
1889 option get : get all       : probe all sites
1890            : get update    : probe a selection of the sites (see doc)
1891            : get url <url> : probe some <url> (in the mirror-list).
1892 option c   : configuration file ; default search :
1893              ( $DEF_CNF )
1894 -------------------------------------------------------------------
1895 Mirmon normally only reports errors and changes in the mirror list.
1896 This is $VERSION.
1897 -------------------------------------------------------------------
1898 USAGE
1899 sub Usage { die "$_[0]$Usage" ; }
1900 sub Error { die "$prog: $_[0]\n" ; }
1901 sub Warn  { warn "$prog: $_[0]\n" ; }
1902
1903 # usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
1904 # usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
1905 # ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
1906 # ID  = perl identifier
1907 # SPC = i|f|s for integer, fixedpoint real or string argument
1908
1909 use Getopt::Long ;
1910 Getopt::Long::config ( 'no_ignore_case' ) ;
1911 my %opt = () ;
1912 Usage '' unless GetOptions ( \%opt, qw(v q t=i get=s c=s version) ) ;
1913 Usage "Arg count\n" if @ARGV > 1 ;
1914 Usage "Arg count\n" if $opt{get} and $opt{get} eq 'url' and ! @ARGV ;
1915
1916 if ( $opt{version} ) { printf "%s\n", Base::version () ; exit ; }
1917
1918 $opt{v} ||= $opt{d} ;
1919
1920 my $URL = shift ;
1921
1922 my $M = Mirmon -> new ( $opt{c} ) ;
1923 $M -> conf -> timeout ( $opt{t} ) if $opt{t} ;
1924
1925 my $get = $opt{get} ;
1926 if ( $get )
1927   { Error "url $URL not in list"
1928       if $get eq 'url' and ! $M -> state -> { $URL } ;
1929     Error "unknown 'get option' '$get'" unless Base::is_get_opt ( $get ) ;
1930   }
1931
1932 Mirmon::verbose ( $opt{v} ) ;
1933 Mirmon::debug   ( $opt{d} ) ;
1934 Mirmon::quiet   ( $opt{q} ) ;
1935
1936 if ( $get ) { $M -> get_dates ( $get, $URL ) ; $M -> put_state ; }
1937 $M -> gen_page ( $get, $VERSION ) ;
1938
1939 __END__
1940
1941 =pod
1942
1943 =head1 NAME
1944
1945 mirmon - monitor the state of mirrors
1946
1947 =head1 SYNOPSIS
1948
1949   mirmon [-v] [-q] [-t timeout] [-c conf] [-get all|update|url url]
1950
1951 =head1 OPTIONS
1952
1953 =over 4
1954
1955 =item B<-v>
1956
1957 Be verbose ; B<mirmon> normally only reports
1958 errors and changes in the mirror list.
1959
1960 =item B<-q>
1961
1962 Be quiet.
1963
1964 =item B<-t> I<timeout>
1965
1966 Set the timeout ; the default is I<300>.
1967
1968 =item B<-get> all | update | url <url>
1969
1970 With B<all>, probe all sites.
1971 With B<update>, probe a selection of the sites ; see option C<max_poll> below.
1972 With B<url>, probe only the given I<url>, which must appear in the mirror-list.
1973
1974 =item B<-c> I<name>
1975
1976 Use config file I<name>. The default list is
1977
1978   ./mirmon.conf $HOME/.mirmon.conf /etc/mirmon.conf
1979
1980 =back
1981
1982 =head1 USAGE
1983
1984 The program is intended to be run by cron every hour.
1985
1986   42 * * * * perl /path/to/mirmon -get update
1987
1988 It quietly probes a subset of the sites in a given list,
1989 writes the results in the 'state' file and generates a web page
1990 with the results. The subset contains the sites that are new, bad
1991 and/or not probed for a specified time.
1992
1993 When no 'get' option is specified, the program just generates a
1994 new web page from the last known state.
1995
1996 The program checks the mirrors by running a (user specified)
1997 program on a pipe. A (user specified) number of probes is
1998 run in parallel using nonblocking IO. When something can be
1999 read from the pipe, it switches the pipe to blocking IO and
2000 reads one line from the pipe. Then it flushes and closes the
2001 pipe. No attempt is made to kill the probe.
2002
2003 The probe should return something that looks like
2004
2005   1043625600 ...
2006
2007 that is, a line of text starting with a timestamp. The exit status
2008 of the probe is ignored.
2009
2010 =head1 CONFIG FILE
2011
2012 =head2 location
2013
2014 A config file can be specified with the -c option.
2015 If -c is not used, the program looks for a config file in
2016
2017 =over
2018
2019 =item * B<./mirmon.conf>
2020
2021 =item * B<$HOME/.mirmon.conf>
2022
2023 =item * B</etc/mirmon.conf>
2024
2025 =back
2026
2027 =head2 syntax
2028
2029 A config file looks like this :
2030
2031   +--------------------------------------------------
2032   |# lines that start with '#' are comment
2033   |# blank lines are ignored too
2034   |# tabs are replaced by a space
2035   |
2036   |# the config entries are 'key' and 'value' pairs
2037   |# a 'key' begins in column 1
2038   |# the 'value' is the rest of the line
2039   |somekey  A_val B_val ...
2040   |otherkey X_val Y_val ...
2041   |
2042   |# indented lines are glued
2043   |# the next three lines mean 'somekey part1 part2 part3'
2044   |somekey part1
2045   |  part2
2046   |  part3
2047   |
2048   |# lines starting with a '+' are concatenated
2049   |# the next three lines mean 'somekey part1part2part3'
2050   |somekey part1
2051   |+ part2
2052   |+ part3
2053   |
2054   |# lines starting with a '.' are glued too
2055   |# don't use a '.' on a line by itself
2056   |# 'somekey' gets the value "part1\n part2\n part3"
2057   |somekey part1
2058   |. part2
2059   |. part3
2060   +--------------------------------------------------
2061
2062 =head2 required entries
2063
2064 =over 4
2065
2066 =item project_name I<name>
2067
2068 Specify a short plaintext name for the project.
2069
2070   project_name Apache
2071   project_name CTAN
2072
2073 =item project_url I<url>
2074
2075 Specify an url pointing to the 'home' of the project.
2076
2077   project_url http://www.apache.org/
2078
2079 =item mirror_list I<file-name>
2080
2081 Specify the file containing the mirrors to probe.
2082
2083   mirror_list /path/to/mirror-list
2084
2085 If your mirror list is generated by a program, use
2086
2087   mirror_list /path/to/program arg1 ... |
2088
2089 Two formats are supported :
2090
2091 =over
2092
2093 =item * plain : lines like
2094
2095   us http://www.tux.org/ [email] ...
2096   nl http://apache.cs.uu.nl/dist/ [email] ...
2097   nl rsync://archive.cs.uu.nl/apache-dist/ [email] ...
2098
2099 =item * apache : lines like those in the apache mirrors.list
2100
2101   ftp  us ftp://ftp.tux.org/pub/net/apache/dist/ user@tux.org ...
2102   http nl http://apache.cs.uu.nl/dist/ user@cs.uu.nl ...
2103
2104 =back
2105
2106 Note that in style 'plain' the third item is reserved for an
2107 optional email address : the site's contact address.
2108
2109 Specify the required format with option C<list_style> (see below).
2110 The default style is 'plain'.
2111
2112 =item web_page I<file-name>
2113
2114 Specify where the html report page is written.
2115
2116 =item icons I<directory-name>
2117
2118 Specify the directory where the icons can be found,
2119 relative to the I<web_page>, or relative to the
2120 DOCUMENTROOT of the web server.
2121
2122 If/when the I<web_page> lives in directory C<.../mirmon/> and
2123 the icons live in directory C<.../mirmon/icons/>,
2124 specify
2125
2126   icons icons
2127
2128 If/when the icons live in C</path/to/DOCUMENTROOT/icons/mirmon/>, specify
2129
2130   icons /icons/mirmon
2131
2132 =item probe I<program + arguments>
2133
2134 Specify the program+args to probe the mirrors. Example:
2135
2136   probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME.txt
2137
2138 Before the program is started, %TIMEOUT% and %URL% are
2139 substituted with the proper timeout and url values.
2140
2141 Here it is assumed that each hour the root server writes
2142 a timestamp in /path/to/archive/TIME.txt, for instance with
2143 a crontab entry like
2144
2145   42 * * * * perl -e 'print time, "\n"' > /path/to/archive/TIME.txt
2146
2147 Mirmon reads one line of output from the probe and interprets
2148 the first word on that line as a timestamp ; for example :
2149
2150   1043625600
2151   1043625600 Mon Jan 27 00:00:00 2003
2152   1043625600 www.apache.org Mon Jan 27 00:00:00 2003
2153
2154 Mirmon is distributed with a program C<probe> that handles
2155 ftp, http and rsync urls.
2156
2157 =item state I<file-name>
2158
2159 Specify where the file containing the state is written.
2160
2161 The program reads this file on startup and writes the
2162 file when mirrors are probed (-get is specified).
2163
2164 =item countries I<file-name>
2165
2166 Specify the file containing the country codes;
2167 The file should contain lines like
2168
2169   us - United States
2170   nl - Netherlands
2171
2172 The mirmon package contains a recent ISO list.
2173
2174 I<Fake> domains like I<Backup>, I<Master> are allowed,
2175 and are listed first in the report ; lowercase-first
2176 fake domains (like I<backup>) are listed last.
2177
2178 =back
2179
2180 =head2 optional entries
2181
2182 =over 4
2183
2184 =item max_probes I<number>
2185
2186 Optionally specify the number of parallel probes (default 25).
2187
2188 =item timeout I<seconds>
2189
2190 Optionally specify the timeout for the probes (default 300).
2191
2192 After the last probe is started, the program waits for
2193 <timeout> + 10 seconds, cleans up and exits.
2194
2195 =item project_logo I<logo>
2196
2197 Optionally specify (the SRC of the IMG of) a logo to be placed
2198 top right on the page.
2199
2200   project_logo /icons/apache.gif
2201   project_logo http://www.apache.org/icons/...
2202
2203 =item htm_head I<html>
2204
2205 Optionally specify some HTML to be placed before </HEAD>.
2206
2207   htm_head
2208     <link REL=StyleSheet HREF="/style.css" TYPE="text/css">
2209
2210 =item htm_top I<html>
2211
2212 Optionally specify some HTML to be placed near the top of the page.
2213
2214   htm_top testing 1, 2, 3
2215
2216 =item htm_foot I<html>
2217
2218 Optionally specify HTML to be placed near the bottom of the page.
2219
2220   htm_foot
2221     <HR>
2222     <A HREF="..."><IMG SRC="..." BORDER=0></A>
2223     <HR>
2224
2225 =item put_histo top|bottom|nowhere
2226
2227 Optionally specify where the age histogram must be placed.
2228 The default is 'top'.
2229
2230 =item min_poll I<time-spec>
2231
2232 For 'min_poll' see next item. A I<time-spec> is a number followed by
2233 a unit 's' (seconds), or 'm' (minutes), or 'h' (hours), or 'd' (days).
2234 For example '3d' (three days) or '36h' (36 hours).
2235
2236 =item max_poll I<time-spec>
2237
2238 Optionally specify the maximum probe interval. When the program is
2239 called with option '-get update', all sites are probed which are :
2240
2241 =over 4
2242
2243 =item * new
2244
2245 the site appears in the list, but there is no known state
2246
2247 =item * bad
2248
2249 the last probe of the site was unsuccessful
2250
2251 =item * old
2252
2253 the last probe was more than 'max_poll' ago.
2254
2255 =back
2256
2257 Sites are not probed if the last probe was less than 'min_poll' ago.
2258 So, if you specify
2259
2260   min_poll 4h
2261   max_poll 12h
2262
2263 the 'reachable' sites are probed twice daily and the 'unreachable'
2264 sites are probed at most six times a day.
2265
2266 The default 'min_poll' is '1h' (1 hour).
2267 The default 'max_poll' is '4h' (4 hours).
2268
2269 =item min_sync I<time-spec>
2270
2271 Optionally specify how often the mirrors are required to make an update.
2272
2273 The default 'min_sync' is '1d' (1 day).
2274
2275 =item max_sync I<time-spec>
2276
2277 Optionally specify the maximum allowable sync interval.
2278
2279 Sites exceeding the limit will be considered 'old'.
2280 The default 'max_sync' is '2d' (2 days).
2281
2282 =item always_get I<region ...>
2283
2284 Optionally specify a list of regions that must be probed always.
2285
2286   always_get Master Tier1
2287
2288 This is intended for I<fake regions> like I<Master> etc.
2289
2290 =item no_randomize
2291
2292 Mirmon tries to balance the probe load over the hourly mirmon runs.
2293 If the current run has a below average number of mirrors to probe,
2294 mirmon probes a few extra, randomly chosen mirrors, picked from the
2295 runs that have the highest load.
2296
2297 If you don't want this behaviour, use B<no_randomize>.
2298
2299 =item no_add_slash
2300
2301 If the url part of a line in the mirror_list doesn't end
2302 in a slash ('/'), mirmon adds a slash and issues a warning
2303 unless it is in quiet mode.
2304
2305 If you don't want this behaviour, use B<no_add_slash>.
2306
2307 =item list_style plain|apache
2308
2309 Optionally specify the format ('plain' or 'apache') of the mirror-list.
2310
2311 See the description of 'mirror_list' above.
2312 The default list_style is 'plain'.
2313
2314 =item site_url I<site> I<url>
2315
2316 Optionally specify a substitute url for a site.
2317
2318 When access to a site is restricted (in Australia, for instance),
2319 another (sometimes secret) url can be used to probe the site.
2320 The <site> of an url is the part between '://' and the first '/'.
2321
2322 =item env I<key> I<value>
2323
2324 Optionally specify an environment variable.
2325
2326 =item include I<file-name>
2327
2328 Optionally specify a file to include.
2329
2330 The specified file is processed 'in situ'. After the specified file is
2331 read and processed, config processing is resumed in the file where the
2332 C<include> was encountered.
2333 The include depth is unlimited. However, it is a fatal error to
2334 include a file twice under the same name.
2335
2336 =item show
2337
2338 When the config processor encounters the 'show' command, it
2339 dumps the content of the current config to standout, if option
2340 C<-v> is specified. This is intented for debugging.
2341
2342 =item exit
2343
2344 When the config processor encounters the 'exit' command, it
2345 terminates the program. This is intented for debugging.
2346
2347 =back
2348
2349 =head1 STATE FILE FORMAT
2350
2351 The state file consists of lines; one line per site.
2352 Each line consists of white space separated fields.
2353 The seven fields are :
2354
2355 =over 4
2356
2357 =item * field 1 : url
2358
2359 The url as given in the mirror list.
2360
2361 =item * field 2 : age
2362
2363 The mirror's timestamp found by the last successful probe,
2364 or 'undef' if no probe was ever successful.
2365
2366 =item * field 3 : status last probe
2367
2368 The status of the last probe, or 'undef' if the mirror was never probed.
2369
2370 =item * field 4 : time last successful probe
2371
2372 The timestamp of the last successful probe or 'undef'
2373 if the mirror was never successfully probed.
2374
2375 =item * field 5 : probe history
2376
2377 The probe history is a list of 's' (for success) and 'f' (for failure)
2378 characters indicating the result of the probe. New results are appended
2379 whenever the mirror is probed.
2380
2381 =item * field 6 : state history
2382
2383 The state history consists of a timestamp, a '-' char, and a list of
2384 chars indicating a past status: 's' (fresh), 'b' (oldish), 'f' (old),
2385 'z' (bad) or 'x' (skip).
2386 The timestamp indicates when the state history was last updated.
2387 The current status of the mirror is determined by the mirror's age and
2388 a few configuration parameters (min_sync, max_sync, max_poll).
2389 The state history is updated when the mirror is probed.
2390 If the last update of the history was less than 24 hours ago,
2391 the last status is replaced by the current status.
2392 If the last update of the history was more than 24 hours ago,
2393 the current status is appended to the history.
2394 One or more 'skip's is inserted, if the timestamp is two or more days old
2395 (when mirmon hasn't run for more than two days).
2396
2397 =item * field 7 : last probe
2398
2399 The timestamp of the last probe, or 'undef' if the mirror was never probed.
2400
2401 =back
2402
2403 =head1 INSTALLATION
2404
2405 =head2 general
2406
2407 =over 4
2408
2409 =item * Note: The (empty) state file must exist before mirmon runs.
2410
2411 =item * The mirmon repository is here :
2412
2413   https://svn.science.uu.nl/repos/project.mirmon/trunk/
2414
2415 =item * The mirmon tarball is here :
2416
2417   http://www.staff.science.uu.nl/~penni101/mirmon/mirmon.tar.gz
2418
2419 =back
2420
2421 =head2 installation suggestions
2422
2423 To install and configure mirmon, take the following steps :
2424
2425 =over 2
2426
2427 =item * First, make the webdir :
2428
2429   cd DOCUMENTROOT
2430   mkdir mirmon
2431
2432 For I<DOCUMENTROOT>, substitute the full pathname
2433 of the document root of your webserver.
2434
2435 =item * Check out the mirmon repository :
2436
2437   cd /usr/local/src
2438   svn checkout REPO mirmon
2439
2440 where
2441
2442   REPO = https://svn.science.uu.nl/repos/project.mirmon/trunk/
2443
2444 or download the package and unpack it.
2445
2446 =item * Chdir to directory mirmon :
2447
2448   cd mirmon
2449
2450 =item * Create the (empty) state file :
2451
2452   touch state.txt
2453
2454 =item * Install the icons in the webdir :
2455
2456   mkdir DOCUMENTROOT/mirmon/icons
2457   cp icons/* DOCUMENTROOT/mirmon/icons
2458
2459 =item * Create a mirror list C<mirror_list> ;
2460
2461 Use your favorite editor, or genererate the list from an
2462 existing database.
2463
2464   nl http://archive.cs.uu.nl/your-project/ contact@cs.uu.nl
2465   uk http://mirrors.this.org/your-project/ mirrors@this.org
2466   us http://mirrors.that.org/your-project/ mirrors@that.org
2467
2468 The email addresses are optional.
2469
2470 =item * Create a mirmon config file C<mirmon.conf> with your favorite editor.
2471
2472   # lines must start in the first column ; no leading white space
2473   project_name ....
2474   project_url  ....
2475   mirror_list mirror_list
2476   state state.txt
2477   countries countries.list
2478   web_page DOCUMENTROOT/mirmon/index.html
2479   icons /mirmon/icons
2480   probe /usr/bin/wget -q -O - -T %TIMEOUT% -t 1 %URL%TIME.txt
2481
2482 This assumes the project's timestamp is in file C<TIME.txt>.
2483
2484 =item * If you have rsync urls, change the probe line to :
2485
2486   probe perl /usr/local/src/mirmon/probe -t %TIMEOUT% %URL%TIME.txt
2487
2488 =item * Run mirmon :
2489
2490   perl mirmon -v -get all
2491
2492 The mirmon report should now be in 'DOCUMENTROOT/mirmon/index.html'
2493
2494   http://www.your.project.org/mirmon/
2495
2496 =item * If/when, at a later date, you want to upgrade mirmon :
2497
2498   cd /usr/local/src/mirmon
2499   svn status -u
2500   svn up
2501
2502 =back
2503
2504 =head1 SEE ALSO
2505
2506 =begin html
2507
2508 <p>
2509 <a href="mirmon.pm.html">mirmon.pm(3)</a>
2510 </p>
2511
2512 =end html
2513
2514 =begin man
2515
2516 mirmon.pm(3)
2517
2518 =end man
2519
2520 =head1 AUTHOR
2521
2522 =begin html
2523
2524   <p>
2525   &copy; 2003-2014
2526   <a href="http://www.staff.science.uu.nl/~penni101/">Henk P. Penning</a>,
2527   <a href="http://www.uu.nl/faculty/science/EN/">Faculty of Science</a>,
2528   <a href="http://www.uu.nl/">Utrecht University</a>
2529   <br />
2530   mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp ;
2531   <a href="http://validator.w3.org/check?uri=referer">verify html</a>
2532   </p>
2533
2534 =end html
2535
2536 =begin man
2537
2538   (c) 2003-2014 Henk P. Penning
2539   Faculty of Science, Utrecht University
2540   http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
2541   mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp
2542
2543 =end man
2544
2545 =begin text
2546
2547   (c) 2003-2014 Henk P. Penning
2548   Faculty of Science, Utrecht University
2549   http://www.staff.science.uu.nl/~penni101/ -- penning@uu.nl
2550   mirmon-2.10 - Fri Aug 15 12:26:55 2014 ; henkp
2551
2552 =end text
2553
2554 =cut