#! /usr/bin/perl -w
-
+# $Cambridge$
+#
# Copyright (c) 2003 Henk Penning, all rights reserved.
# penning@cs.uu.nl, http://www.cs.uu.nl/staff/henkp.html
# Version 1.1 was donated to the Apache Software Foundation 2003 Jan 28
-# $Id: mirmon,v 1.36 2004/12/28 17:54:10 henkp Exp $
+# $Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following conditions:
-#
+#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
-#
+#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
+#
+# Thanks to Klaus Heinz <heinz@NetBSD.org> for sugestions ao htm_head
my $PRG = 'mirmon' ;
-my $VER = '$Id: mirmon,v 1.36 2004/12/28 17:54:10 henkp Exp $' ;
+my $VER = '$Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $' ;
use strict ;
use IO::Pipe ;
) ;
my @OPT_KEYS =
qw( project_logo min_poll min_sync max_sync list_style htm_top htm_foot
- put_histo
+ htm_head put_histo
) ;
my %CNF_KEYS ; for ( @REQ_KEYS, @OPT_KEYS, keys %CNF )
{ $CNF_KEYS { $_ } ++ ; }
}
for my $key ( sort keys %HREF )
{ printf "show_conf : for site '%s' use instead\n '%s'\n",
- $key, $HREF { $key } if $opt{v} ;
+ $key, $HREF { $key } if $opt{v} ;
}
printf "show_conf : included '%s'\n", join "', '", @{ $CNF{_include} } ;
print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" ;
{ my ($key,$val) = split ' ', $_, 2 ;
$val = '' unless defined $val ;
print "conf '$FILE' : key '$key', val '$val'\n" if $opt{d} ;
- if ( exists $CNF_KEYS { $key } )
- { $CNF { $key } = $val ; }
- elsif ( $key eq 'site_url' )
- { my ( $site, $url ) = split ' ' , $val ;
- $url .= '/' unless $url =~ m!/$! ;
- $HREF { lc $site } = $url ;
- printf "config : for site '%s' use instead\n '%s'\n",
- $site, $url if $opt{v} ;
- }
- elsif ( $key eq 'env' )
- { my ( $x, $y ) = split ' ' , $val ;
- $ENV { $x } = $y ;
- printf "config : setenv '%s'\n '%s'\n", $x, $y if $opt{v} ;
- }
- elsif ( $key eq 'no_randomize' )
- { $CNF { randomize } = 0 ; }
- elsif ( $key eq 'include' )
- { get_conf $val ; }
- elsif ( $key eq 'show' )
- { show_conf unless $opt{q} ; }
- elsif ( $key eq 'exit' )
- { Error 'exit per config directive' ; }
- elsif ( $key eq 'max_age' )
- { $CNF { max_sync } = $val ; }
- else
- { show_conf ;
- Error "unknown keyword '$key' (value '$val')" ;
- }
+ if ( exists $CNF_KEYS { $key } )
+ { $CNF { $key } = $val ; }
+ elsif ( $key eq 'site_url' )
+ { my ( $site, $url ) = split ' ' , $val ;
+ $url .= '/' unless $url =~ m!/$! ;
+ $HREF { lc $site } = $url ;
+ printf "config : for site '%s' use instead\n '%s'\n",
+ $site, $url if $opt{v} ;
+ }
+ elsif ( $key eq 'env' )
+ { my ( $x, $y ) = split ' ' , $val ;
+ $ENV { $x } = $y ;
+ printf "config : setenv '%s'\n '%s'\n", $x, $y if $opt{v} ;
+ }
+ elsif ( $key eq 'no_randomize' )
+ { $CNF { randomize } = 0 ; }
+ elsif ( $key eq 'include' )
+ { get_conf $val ; }
+ elsif ( $key eq 'show' )
+ { show_conf unless $opt{q} ; }
+ elsif ( $key eq 'exit' )
+ { Error 'exit per config directive' ; }
+ elsif ( $key eq 'max_age' )
+ { $CNF { max_sync } = $val ; }
+ else
+ { show_conf ;
+ Error "unknown keyword '$key' (value '$val')" ;
+ }
}
}
if ( exists $OLD { $url } )
{ $time = $OLD { $url } [ 0 ] ;
$vrfy = $OLD { $url } [ 2 ] ;
- $hstp = substr $OLD { $url } [ 3 ], 1 - $HIST ;
+ $hstp = substr $OLD { $url } [ 3 ], 1 - $HIST ;
$hsts = $OLD { $url } [ 4 ] ;
}
else
{ $time = 'undef' ;
$vrfy = 'undef' ;
- $hstp = '' ;
+ $hstp = '' ;
$hsts = '' ;
}
$RES { $url } = [ $time, $stat, $vrfy, $hstp . 'f', $hsts, $^T ] ;
while ( <STT> )
{ chop ;
my ( $url, $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = split ' ' ;
- $stat =~ s/_/ /g ;
- $hstp = '' unless defined $hstp ;
- $hsts = '' unless defined $hsts ;
- $hsts = '' if $hsts eq 'undef' ;
- $lprb = 'undef' unless defined $lprb ;
- $OLD { $url } = [ $time, $stat, $vrfy, $hstp, $hsts, $lprb ] ;
+ $stat =~ s/_/ /g ;
+ $hstp = '' unless defined $hstp ;
+ $hsts = '' unless defined $hsts ;
+ $hsts = '' if $hsts eq 'undef' ;
+ $lprb = 'undef' unless defined $lprb ;
+ $OLD { $url } = [ $time, $stat, $vrfy, $hstp, $hsts, $lprb ] ;
}
close STT ;
}
if ( aprx_le $stmp, $^T - tim_to_s '1d' )
{ $res = sprintf "%s-%s%s"
- , $^T
- , substr ( $hist, 1 - $HIST )
- , age_code ( $time )
- ;
+ , $^T
+ , substr ( $hist, 1 - $HIST )
+ , age_code ( $time )
+ ;
}
return $res ;
}
my @OUT = @{ $RES { $url } } ;
$OUT [ 1 ] =~ s/\s/_/g ;
printf TMP "%s %s\n", $url, join ' ', @OUT
- or Error "can't print to $TMP ($!)" ;
+ or Error "can't print to $TMP ($!)" ;
}
close TMP ;
if ( -z $TMP )
{ chop ;
next if /^#/ ;
my ( $code, $dash, $reg ) = split ' ', $_, 3 ;
- $CCS { lc $code } = lc $reg ;
+ $CCS { lc $code } = lc $reg ;
}
close CCS ;
}
while ( <LST> )
{ chop ;
next if /^#/ ;
- next if /^\s*$/ ;
+ next if /^\s*$/ ;
if ( $CNF { list_style } eq 'plain' )
- { ( $reg, $url ) = split ' ' ;
- unless ( $url =~ m!/$! )
- { print "*** mirmon appended '/' to $url\n" unless $opt{q} ;
- $url .= '/' ;
- }
- }
- elsif ( $CNF { list_style } eq 'apache' )
- { my $apache_type ;
- ( $apache_type, $reg, $url ) = split ' ' ;
- unless ( defined $APA_TYPES { $apache_type } )
- { print "*** strange type : $apache_type\n" unless $opt{q} ;
- next ;
- }
- unless ( $url =~ m!/$! )
- { print "*** missing '/' in $url\n" unless $opt{q} ;
- $url .= '/' ;
- }
- }
-
- my $site = site $url ;
- my $type = type $url ;
-
- unless ( defined $site )
- { print "*** strange url : '$url'\n" unless $opt{q} ; next ; }
+ { ( $reg, $url ) = split ' ' ;
+ unless ( $url =~ m!/$! )
+ { print "*** mirmon appended '/' to $url\n" unless $opt{q} ;
+ $url .= '/' ;
+ }
+ }
+ elsif ( $CNF { list_style } eq 'apache' )
+ { my $apache_type ;
+ ( $apache_type, $reg, $url ) = split ' ' ;
+ unless ( defined $APA_TYPES { $apache_type } )
+ { print "*** strange type : $apache_type\n" unless $opt{q} ;
+ next ;
+ }
+ unless ( $url =~ m!/$! )
+ { print "*** missing '/' in $url\n" unless $opt{q} ;
+ $url .= '/' ;
+ }
+ }
+
+ my $site = site $url ;
+ my $type = type $url ;
+
+ unless ( defined $site )
+ { print "*** strange url : '$url'\n" unless $opt{q} ; next ; }
$LST { $url } = [ $type , $site, $reg ] ;
}
while ( $hst ne '' )
{ if ( substr ( $prf, 0, 1 ) eq substr ( $hst, 0, 1 ) )
{ $cnt ++ ;
- $hst = substr $hst, 1 ;
- }
+ $hst = substr $hst, 1 ;
+ }
else
- { $res .= img_sf_cnt $prf, $cnt ;
- $prf = substr $hst, 0, 1 ;
- $hst = substr $hst, 1 ;
- $cnt = 1 ;
- }
+ { $res .= img_sf_cnt $prf, $cnt ;
+ $prf = substr $hst, 0, 1 ;
+ $hst = substr $hst, 1 ;
+ $cnt = 1 ;
+ }
}
$res .= img_sf_cnt $prf, $cnt if $cnt ;
return $res ;
for my $url ( keys %RES )
{ ( $time, $stat, $vrfy, $hstp, $hsts, $lprb ) = @{ $RES { $url } } ;
my $hr = int ( ( $^T - $lprb ) / 3600 + 0.5 ) ;
- $hr_min = $hr if ! defined $hr_min or $hr < $hr_min ;
- $hr_max = $hr if ! defined $hr_max or $hr > $hr_max ;
+ $hr_min = $hr if ! defined $hr_min or $hr < $hr_min ;
+ $hr_max = $hr if ! defined $hr_max or $hr > $hr_max ;
if ( $stat eq 'ok' )
- { $tab { $hr } ++ ; $s_cnt ++ ; }
- else
- { $bad { $hr } ++ ; $f_cnt ++ ; }
+ { $tab { $hr } ++ ; $s_cnt ++ ; }
+ else
+ { $bad { $hr } ++ ; $f_cnt ++ ; }
}
$res = TR
( TH ( 'hours ago' )
. TH sprintf
( '%s %s, %s %s'
, $s_cnt , GRN ( 'successful' )
- , $f_cnt , RED ( 'failed' )
+ , $f_cnt , RED ( 'failed' )
)
) ;
my $y = $bad { $hr } || 0 ;
my $n = int ( $x / $max * $HIST ) ;
my $b = int ( $y / $max * $HIST ) ;
- $res .= TR
- ( TDr ( $hr )
- . TDr ( $x )
- . TDr ( $y )
- . TD
- ( ( $n ? img_sf_cnt ( 's', $n ) : '' )
- . ( $b ? img_sf_cnt ( 'f', $b ) : '' )
- . ( ( $n + $b ) ? '' : ' ' )
- )
- ) ;
+ $res .= TR
+ ( TDr ( $hr )
+ . TDr ( $x )
+ . TDr ( $y )
+ . TD
+ ( ( $n ? img_sf_cnt ( 's', $n ) : '' )
+ . ( $b ? img_sf_cnt ( 'f', $b ) : '' )
+ . ( ( $n + $b ) ? '' : ' ' )
+ )
+ ) ;
}
return "<BLOCKQUOTE>\n" . TAB ( $res ) . "</BLOCKQUOTE>\n" ;
}
for my $url ( keys %RES )
{ my $time = $RES { $url } [ 0 ] ;
if ( $time =~ /^\d+$/ )
- { my $s = $^T - $time ;
- my $hr = int ( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 ) ;
- if ( $s <= $MAX_H ) { $tab { $hr } ++ ; }
- elsif ( $s <= $MAX_O ) { $tab { old } ++ ; }
- else { $tab { ded } ++ ; }
- }
- else
- { $tab { bad } ++ ; }
+ { my $s = $^T - $time ;
+ my $hr = int ( $s / $MAX_H * ( $MAX_h - 1 ) + 0.5 ) ;
+ if ( $s <= $MAX_H ) { $tab { $hr } ++ ; }
+ elsif ( $s <= $MAX_O ) { $tab { old } ++ ; }
+ else { $tab { ded } ++ ; }
+ }
+ else
+ { $tab { bad } ++ ; }
}
my $max = 0 ;
for ( grep ! exists $Wmx { $_ }, keys %tab )
my $d = int ( $bad { $aux } / $W { $aux } ) ;
for ( my $i = 1 ; $i < $W { $aux } ; $i++ )
{ $tab { $aux . $i } = $d ;
- if ( $bad { $aux } % $Wmx { $aux } > $i )
- { $tab { $aux . $i } ++ ;
- $tab { $aux } -- ;
- }
- }
+ if ( $bad { $aux } % $Wmx { $aux } > $i )
+ { $tab { $aux . $i } ++ ;
+ $tab { $aux } -- ;
+ }
+ }
$tab { $aux } -= ( $W { $aux } - 1 ) * $d ;
- $max = $tab { $aux } if $max < $tab { $aux } ;
+ $max = $tab { $aux } if $max < $tab { $aux } ;
}
}
;
for ( my $h = $H ; $h > 0 ; $h -- )
{ $res .= "<TR>\n" ;
- $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"TOP\">↑</TH>\n"
- if $h == $H ;
- $res .= sprintf '<TD ROWSPAN=%d ALIGN="CENTER">%s</TD>' . "\n"
- , $H-6, NSS ( $max ) if $h == $H - 3 ;
- $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"BOTTOM\">↓</TH>\n"
- if $h == 3 ;
+ $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"TOP\">↑</TH>\n"
+ if $h == $H ;
+ $res .= sprintf '<TD ROWSPAN=%d ALIGN="CENTER">%s</TD>' . "\n"
+ , $H-6, NSS ( $max ) if $h == $H - 3 ;
+ $res .= sprintf "<TH ROWSPAN=3 VALIGN=\"BOTTOM\">↓</TH>\n"
+ if $h == 3 ;
for my $x ( @keys )
- { $res .= sprintf "<TH>%s</TH>\n"
- , ( ( $hst { $x } >= $h )
- ? img_sf
- ( $x =~ /^\d+$/
- ? 's'
- : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) )
- )
- : ( ( $h == 1 and $hst { $x } == 0 )
- ? sprintf
-
( '<IMG SRC="%s/bar.gif" ALT="" BORDER=0>'
- , $CNF { icons }
- )
- : ''
- )
- ) ;
- }
+ { $res .= sprintf "<TH>%s</TH>\n"
+ , ( ( $hst { $x } >= $h )
+ ? img_sf
+ ( $x =~ /^\d+$/
+ ? 's'
+ : ( $x =~ /^old/ ? 'b' : ( $x =~ /^ded/ ? 'f' : 'z' ) )
+ )
+ : ( ( $h == 1 and $hst { $x } == 0 )
+ ? sprintf
+ ( '<IMG SRC="%s/bar.gif" ALT="" BORDER=0>'
+ , $CNF { icons }
+ )
+ : ''
+ )
+ ) ;
+ }
$res .= "</TR>\n" ;
}
$res .= "</TR>\n" ;
my $FRMT = '<TD ALIGN="CENTER" COLSPAN=%d> %s </TD>' ;
-
+
$res .= "<TR>\n" ;
$res .= sprintf "$FRMT\n", 1, NSS scalar keys %RES ;
$res .= "<TH>|</TH>\n" ;
{ $res .= sprintf
"<BR>each %s %s %s %s unit represents %s mirror sites.\n"
, img_sf ( 's' ) , img_sf ( 'f' ), img_sf ( 'b' ) , img_sf ( 'z' )
- , sprintf ( "%.1f", $max / $H )
+ , sprintf ( "%.1f", $max / $H )
}
return $res ;
}
{ my ( $time, $stat, $vrfy ) = @{ $RES { $url } } ;
if ( $stat eq 'ok' ) { $ok ++ ; } else { $stats { $stat } ++ ; }
if ( $time eq 'undef' )
- { $bad ++ ; }
- elsif ( 'f' eq age_code $time )
- { $old ++ ; }
- if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - max_vrfy )
- { $unr ++ ; }
+ { $bad ++ ; }
+ elsif ( 'f' eq age_code $time )
+ { $old ++ ; }
+ if ( $vrfy eq 'undef' or aprx_lt $vrfy, $^T - max_vrfy )
+ { $unr ++ ; }
}
my $STAT = sprintf
for my $reg ( sort keys %tab )
{ $refs .= sprintf " %s \n"
, url "#$reg"
- , "<FONT SIZE=\"+1\">$reg</FONT>"
- ;
+ , "<FONT SIZE=\"+1\">$reg</FONT>"
+ ;
}
my $COLS = 5 ;
my $LOGO = $CNF { project_logo }
? url
( $CNF { project_url }
- , sprintf
+ , sprintf
( '<IMG SRC="%s" ALT="%s" ALIGN="RIGHT" BORDER=0>'
- , $CNF { project_logo }
- , $CNF { project_name }
- )
+ , $CNF { project_logo }
+ , $CNF { project_name }
+ )
)
: ''
;
my $HTOP = $CNF{htm_top} ? $CNF{htm_top} . "\n" : '' ;
my $FOOT = $CNF{htm_foot} ? $CNF{htm_foot} . "\n" : '' ;
+ my $HEAD = $CNF{htm_head} ? $CNF{htm_head} . "\n" : '' ;
my $TITL = url $CNF{project_url}, $CNF{project_name} ;
my $EXPD = exp_date ;
open PPP, ">$TMP" or Error "can't write $TMP ($!)" ;
print PPP '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01'
. ' Transitional//EN"'
-# . ' "http://www.w3.org/TR/html4/loose.dtd"'
. '>' ;
print PPP "<HTML>\n" ;
print PPP "<HEAD>\n" ;
. 'CONTENT="text/html; charset=ISO-8859-1">' ;
print PPP "<META HTTP-EQUIV=\"refresh\" CONTENT=\"3600\">\n" ;
print PPP "<META HTTP-EQUIV=\"Expires\" CONTENT=\"$EXPD\">\n" ;
+ print PPP $HEAD if $HEAD ;
print PPP "</HEAD>\n" ;
print PPP "<BODY BGCOLOR=\"#FFFFFF\">\n" ;
print PPP $LOGO ;
my $ccs = exists $CCS { $reg } ? $CCS { $reg } : $reg ;
$ccs = nam $reg,
- ( scalar @{ $itms } > 6
- ? sprintf "%s - %d sites"
- , $ccs, scalar @{ $itms }
- : $ccs
- ) ;
+ ( scalar @{ $itms } > 6
+ ? sprintf "%s - %d sites"
+ , $ccs, scalar @{ $itms }
+ : $ccs
+ ) ;
- my $attr3 = "COLSPAN=$COLS BGCOLOR=\"YELLOW\"" ;
+ my $attr3 = "COLSPAN=$COLS BGCOLOR=\"YELLOW\"" ;
printf PPP "<TR><TH $attr3>$ccs</TH></TR>\n" ;
- for my $itm ( sort by_type_site @{ $itms } )
- { my ( $type, $url, $site ) = @{ $itm } ;
- my ( $time, $stat, $hstp, $hsts, $vrfy ) ;
- my ( $pr_time, $pr_last, $pr_hstp, $pr_hsts ) ;
-
- print PPP "<TR>\n" ;
- printf PPP
- " <TD ALIGN=\"RIGHT\">%s %s</TD>\n"
- . " <TD>%s</TD>\n"
- , url ( $url , $site )
- , url ( home ( $url ), '@' )
- , $type
- ;
-
- if ( exists $RES { $url } )
- { ( $time, $stat, $vrfy, $hstp, $hsts ) = @{ $RES { $url } } ;
- $pr_time = $time =~ /^\d+$/
- ? diff $time, $^T - max_age2 : ' ' ;
- $pr_last = $vrfy =~ /^\d+$/
- ? diff $vrfy, $^T - max_vrfy : ' ' ;
+ for my $itm ( sort by_type_site @{ $itms } )
+ { my ( $type, $url, $site ) = @{ $itm } ;
+ my ( $time, $stat, $hstp, $hsts, $vrfy ) ;
+ my ( $pr_time, $pr_last, $pr_hstp, $pr_hsts ) ;
+
+ print PPP "<TR>\n" ;
+ printf PPP
+ " <TD ALIGN=\"RIGHT\">%s %s</TD>\n"
+ . " <TD>%s</TD>\n"
+ , url ( $url , $site )
+ , url ( home ( $url ), '@' )
+ , $type
+ ;
+
+ if ( exists $RES { $url } )
+ { ( $time, $stat, $vrfy, $hstp, $hsts ) = @{ $RES { $url } } ;
+ $pr_time = $time =~ /^\d+$/
+ ? diff $time, $^T - max_age2 : ' ' ;
+ $pr_last = $vrfy =~ /^\d+$/
+ ? diff $vrfy, $^T - max_vrfy : ' ' ;
$pr_hstp = show_hist $hstp ;
$pr_hsts = show_hist_age $hsts, $time ;
- }
- else
- { ( $pr_time, $pr_last, $pr_hstp, $pr_hsts, $stat ) =
- ( ' ', ' ', '', '', ' ' ) ;
- }
-
- $stat = RED $stat if $stat ne 'ok' ;
- printf PPP " <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n"
- , $pr_time, $pr_hsts ;
- printf PPP " <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n"
- , $pr_last, $pr_hstp ;
- printf PPP " <TD>%s</TD>\n", $stat ;
- print PPP "</TR>\n" ;
- }
+ }
+ else
+ { ( $pr_time, $pr_last, $pr_hstp, $pr_hsts, $stat ) =
+ ( ' ', ' ', '', '', ' ' ) ;
+ }
+
+ $stat = RED $stat if $stat ne 'ok' ;
+ printf PPP " <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n"
+ , $pr_time, $pr_hsts ;
+ printf PPP " <TD ALIGN=\"RIGHT\">%s<BR>%s</TD>\n"
+ , $pr_last, $pr_hstp ;
+ printf PPP " <TD>%s</TD>\n", $stat ;
+ print PPP "</TR>\n" ;
+ }
}
print PPP "</TABLE>\n" ;
print PPP "</BLOCKQUOTE>\n" ;
</BLOCKQUOTE>
</BLOCKQUOTE>
-<H4>last probe, probe stats</H4>
+<H4>last probe, probe stats</H4>
<BLOCKQUOTE>
<B>Last probe</B> indicates when the last successful probe was made.
<FONT COLOR="RED"><B>failure</B></FONT>.
</BLOCKQUOTE>
-<H4>last stat</H4>
+<H4>last stat</H4>
<BLOCKQUOTE>
<B>Last stat</B> gives the status of the last probe.
if ( $res )
{ $WGT -> blocking ( 0 ) ;
$GET -> add ( $WGT ) ;
- $URL { $WGT } = $url ;
+ $URL { $WGT } = $url ;
}
else
{ err $url, 'no pipe' ; }
}
-sub get_date
+sub get_date
{ my $WGT = shift ;
my $url = $URL { $WGT } ;
my $time = undef ;
$WGT -> flush ;
$WGT -> close ;
- unless ( defined $time ) { return err $url, 'no time' ; }
+ return err $url, 'no time' unless defined $time ;
+ return err $url, "empty" if $time =~ /^\s*$/ ;
$time = ( split ' ', $time ) [ 0 ] ;
- if ( $time eq '' )
- { err $url, "empty" ; }
- elsif ( $time !~ /^\d+$/ )
+ if ( $time !~ /^\d+$/ )
{ $time = htmlquote $time ;
$time = substr ( $time, 0, 15 ) . '..' if length $time > 15 ;
err $url, "'$time'" ;
for my $url ( sort keys %LST )
{ if ( $opt{get} eq 'all' or ! exists $OLD { $url } )
{ push @QUE, $url ; }
- elsif ( $opt{get} eq 'update' )
- { my $stat = $OLD { $url } [ 1 ] ;
- my $vrfy = $OLD { $url } [ 2 ] ;
- my $lprb = $OLD { $url } [ 5 ] ;
- if ( ( $lprb eq 'undef'
- or aprx_le $lprb, $^T - tim_to_s $CNF { min_poll }
- )
- and ( $stat ne 'ok'
- or aprx_le $vrfy, $^T - tim_to_s $CNF { max_poll }
- )
- )
- { push @QUE, $url ; }
- elsif ( $CNF { randomize } and 0 == int rand $cnt_LST )
- { push @QUE, $url ; }
- else
- { $RES { $url } = $OLD { $url } ; }
- }
- else
- { Error "unknown opt_get '$opt{get}'" ; }
+ elsif ( $opt{get} eq 'update' )
+ { my $stat = $OLD { $url } [ 1 ] ;
+ my $vrfy = $OLD { $url } [ 2 ] ;
+ my $lprb = $OLD { $url } [ 5 ] ;
+ if ( ( $lprb eq 'undef'
+ or aprx_le $lprb, $^T - tim_to_s $CNF { min_poll }
+ )
+ and ( $stat ne 'ok'
+ or aprx_le $vrfy, $^T - tim_to_s $CNF { max_poll }
+ )
+ )
+ { push @QUE, $url ; }
+ elsif ( $CNF { randomize } and 0 == int rand $cnt_LST )
+ { push @QUE, $url ; }
+ else
+ { $RES { $url } = $OLD { $url } ; }
+ }
+ else
+ { Error "unknown opt_get '$opt{get}'" ; }
}
while ( @QUE )
{ while ( $GET -> count () < $PAR and @QUE )
{ my $url = shift @QUE ;
if ( gethost site $url )
- { start_date $url, $CMD ; }
- else
- { err $url, 'site not found' ; }
+ { start_date $url, $CMD ; }
+ else
+ { err $url, 'site not found' ; }
}
- my @can_read = $GET -> can_read ( 0 ) ;
+ my @can_read = $GET -> can_read ( 0 ) ;
+
+ printf "que %d, get %d, can %d\n",
+ scalar @QUE, $GET -> count (), scalar @can_read
+ if $opt{v} ;
- printf "que %d, get %d, can %d\n",
- scalar @QUE, $GET -> count (), scalar @can_read
- if $opt{v} ;
-
for my $can_read ( @can_read )
- { get_date $can_read ; }
+ { get_date $can_read ; }
sleep 1 ;
}
my $stop = time + $CNF { timeout } + 10 ;
-
+
while ( $GET -> count () and time < $stop )
{ sleep 1 ;
my @can_read = $GET -> can_read ( 0 ) ;
- printf "wait %2d, get %d, can %d\n",
- $stop - scalar time, $GET -> count (), scalar @can_read
- if $opt{v} ;
-
+ printf "wait %2d, get %d, can %d\n",
+ $stop - scalar time, $GET -> count (), scalar @can_read
+ if $opt{v} ;
+
for my $can_read ( @can_read )
- { get_date $can_read ; }
+ { get_date $can_read ; }
}
for my $WGT ( $GET -> handles () )
with the results. The subset contains the sites that are new, bad
and/or not probed for a specified time.
- When no 'get' option is specified, the program just generates a
+ When no 'get' option is specified, the program just generates a
new web page from the last known state.
The program checks the mirrors by running a (user specified)
Here it is assumed that each hour the root server writes
a timestamp in /path/to/archive/TIME, for instance with
a crontab entry like
-
+
42 * * * * perl -e 'printf "%s\n", time' > /path/to/archive/TIME
Mirmon reads one line of output from the probe and interprets
project_logo /icons/apache.gif
project_logo http://www.apache.org/icons/...
-=head2 htm_foot <html>
+=head2 htm_head <html>
- Optionally specify HTML to be placed near the bottom of the page.
+ Optionally specify some HTML to be placed before </HEAD>.
- htm_foot
- <HR>
- <A HREF="..."><IMG SRC="..." BORDER=0></A>
- <HR>
+ htm_head
+ <link REL=StyleSheet HREF="/style.css" TYPE="text/css">
=head2 htm_top <html>
htm_top testing 1, 2, 3
+=head2 htm_foot <html>
+
+ Optionally specify HTML to be placed near the bottom of the page.
+
+ htm_foot
+ <HR>
+ <A HREF="..."><IMG SRC="..." BORDER=0></A>
+ <HR>
+
=head2 put_histo top|bottom|nowhere
Optionally specify where the age histogram must be placed.
<A HREF="http://www.cs.uu.nl/">Computer Science Department</A>,
<A HREF="http://www.uu.nl/">Utrecht University</A>
<BR>
- $Id: mirmon,v 1.36 2004/12/28 17:54:10 henkp Exp $
+ $Id: mirmon,v 1.37 2006/12/04 15:16:11 henkp Exp henkp $
</BLOCKQUOTE>
=end html
git://git.exim.org / mirror-monitor.git / commitdiff