-sub exp_date
- { my @day = qw(Sun Mon Tue Wed Thu Fri Sat) ;
- my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ;
- my @gmt = gmtime time + 3600 ;
- sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT"
- , $day [ $gmt [ 6 ] ]
- , $gmt [ 3 ]
- , $mon [ $gmt [ 4 ] ]
- , $gmt [ 5 ] + 1900
- , @gmt [ 2, 1, 0 ]
- ;
- }
-
-sub find_conf
- { return $opt{c} if $opt{c} ;
- my $HOME = ( getpwuid $< ) [ 7 ] or Error "can get homedir '$<' ($!)" ;
- my @LIST = ( "$PRG.conf" , "$HOME/.$PRG.conf" , $DEF_CNF ) ;
- for my $conf ( @LIST ) { return $conf if -f $conf ; }
- Error sprintf "can't find a config file :\n %s" , join "\n ", @LIST ;
- }
-
-sub show_conf
- { print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n" ;
- for my $key ( sort keys %CNF )
- { next if $key =~ m/^_/ ;
- print "show_conf : $key = '$CNF{$key}'\n" ;
- }
- for my $key ( sort keys %HREF )
- { printf "show_conf : for site '%s' use instead\n '%s'\n",
- $key, $HREF { $key } if $opt{v} ;
- }
- printf "show_conf : included '%s'\n", join "', '", @{ $CNF{_include} } ;
- print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" ;
- }
-
-sub get_conf ;
-
-sub get_conf
- { my $FILE = shift ;
-
- if ( grep $_ eq $FILE, @{ $CNF {_include} } )
- { Error "already included : '$FILE'" ; }
- else
- { push @{ $CNF {_include} }, $FILE ; }
-
- open FILE, $FILE or Error "can't open '$FILE' ($!)" ;
- my $CONF = join "\n", grep /./, <FILE> ;
- close FILE ;
-
- $CONF =~ s/\t/ /g ; # replace tabs
- $CONF =~ s/^[+ ]+// ; # delete leading space, plus
- $CONF =~ s/\n\n\s+/ /g ; # glue continuation lines
- $CONF =~ s/\n\n\+\s+//g ; # glue concatenation lines
- $CONF =~ s/\n\n\./\n/g ; # glue concatenation lines
-
- chop $CONF ;
- print "--$CONF--\n" if $opt{d} ;
- for ( grep ! /^#/, split /\n\n/, $CONF )
- { 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')" ;
- }
- }
- }
-
-sub get_conf_opt
- { my $err = '' ;
- get_conf find_conf ;
- $CNF { timeout } = $opt{t} if $opt{t} ;
- for my $key ( @REQ_KEYS )
- { unless ( exists $CNF { $key } )
- { $err .= "$prog error: missing config for '$key'\n" ; }
- }
- for my $key ( qw(min_poll max_poll max_sync min_sync) )
- { my $max = $CNF { $key } ;
- unless ( $max =~ /$TIM_PAT/o )
- { $err .= "$prog error: $key ($max) doesn't match /$TIM_PAT/\n" ; }
- }
- unless ( grep $CNF { list_style } eq $_, @LIST_STYLE )
- { $err .= sprintf "%s : error: unknown 'list_style' '%s'\n",
- $prog, $CNF { list_style } ;
- }
- unless ( grep $CNF { put_histo } eq $_, @PUT_HGRAM )
- { $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n",
- $prog, $CNF { put_histo } ;
- }
- if ( $opt { get } and not grep $opt { get } eq $_, @GET_OPTS )
- { $err .= sprintf "%s : error: unknown 'get option' '%s'\n",
- $prog, $opt { get } ;
- }
- Error $err if $err ;
- $opt{q} = 0 if $opt{v} ;
- }
-
-sub tim_to_s
- { my $tim = shift ;
- my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 ) ;
- Error "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o ;
- my $m = $1 ; my $u = $2 ;
- return $m * $tab { $u } ;
- }
-
-sub aprx_eq { my ( $t1, $t2 ) = @_ ; abs ( $t1 - $t2 ) < 60 ; }
-sub aprx_ge { my ( $t1, $t2 ) = @_ ; $t1 > $t2 or aprx_eq $t1, $t2 ; }
-sub aprx_le { my ( $t1, $t2 ) = @_ ; $t1 < $t2 or aprx_eq $t1, $t2 ; }
-sub aprx_gt { my ( $t1, $t2 ) = @_ ; $t1 > $t2 and not aprx_eq $t1, $t2 ; }
-sub aprx_lt { my ( $t1, $t2 ) = @_ ; $t1 < $t2 and not aprx_eq $t1, $t2 ; }
-
-sub pr_interval
- { my $s = shift ;
- my ( $magn, $unit ) ;
- my $mins = $s / 60 ; my $m = int ( $mins + 0.5 ) ;
- my $hours = $s / ( 60 * 60 ) ; my $h = int ( $hours + 0.5 ) ;
-
- if ( $s < 50 )
- { $magn = $s ; $unit = 'second' ; }
- elsif ( $m < 50 )
- { $magn = $m ; $unit = 'minute' ; }
- elsif ( $h < 36 )
- { $magn = $h ; $unit = 'hour' ; }
- else
- { $magn = sprintf "%.1f", $hours / 24 ; $unit = 'day' ; }
-
- $unit .= 's' unless $magn == 1 ;
-
- return "$magn $unit" ;
- }
-
-sub max_age1
- { ( tim_to_s $CNF { min_sync } ) + ( tim_to_s $CNF { max_poll } ) ; }
-sub max_age2
- { ( tim_to_s $CNF { max_sync } ) + ( tim_to_s $CNF { max_poll } ) ; }
-
-sub max_vrfy
- { ( tim_to_s $CNF { min_poll } ) + ( tim_to_s $CNF { max_poll } ) ; }
-
-sub age_code
- { my $time = shift ;
- return 'z' unless $time =~ /^\d+$/ ;
- return
- ( ( aprx_ge ( $time, $^T - max_age1 ) )
- ? 's'
- : ( aprx_ge ( $time, $^T - max_age2 ) ? 'b' : 'f' )
- ) ;
- }
-
-sub err
- { my $url = shift ;
- my $stat = shift ;
- printf "*** %-10s %s\n", $stat, $url unless $opt{q} ;
- my ( $time, $vrfy, $hstp, $hsts ) ;
- if ( exists $OLD { $url } )
- { $time = $OLD { $url } [ 0 ] ;
- $vrfy = $OLD { $url } [ 2 ] ;
- $hstp = substr $OLD { $url } [ 3 ], 1 - $HIST ;
- $hsts = $OLD { $url } [ 4 ] ;
- }
- else
- { $time = 'undef' ;
- $vrfy = 'undef' ;
- $hstp = '' ;
- $hsts = '' ;
- }
- $RES { $url } = [ $time, $stat, $vrfy, $hstp . 'f', $hsts, $^T ] ;
- }
-
-sub res
- { my $url = shift ;
- my $time = shift ;
- my $stat = shift ;
- my $hstp =
- ( exists $OLD { $url }
- ? substr ( $OLD { $url } [ 3 ], 1 - $HIST )
- : ''
- ) ;
- my $hsts = ( exists $OLD { $url } ? $OLD { $url } [ 4 ] : '') ;
- printf "result %d %s\n", $time, $url if $opt{v} ;
- $RES { $url } = [ $time, $stat, $^T, $hstp . 's', $hsts, $^T ] ;
- }
-
-sub get_state
- { my $STT = shift ;
- open STT, $STT or Error "can't open '$STT' ($!)" ;
- 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 ] ;
- }
- close STT ;
- }
-
-sub check_hist
- { my $time = shift ;
- my $hsts = shift ;
- printf "check_hist: last '$time' hsts '$hsts'\n" if $opt{d} ;
-
- my $res = $hsts ;
- my ( $stmp, $hist ) ;
-
- if ( $hsts eq '' )
- { $stmp = 0 ; $hist = '' ; }
- else
- { ( $stmp, $hist ) = split '-', $hsts ; }
-
- if ( aprx_le $stmp, $^T - tim_to_s '1d' )
- { $res = sprintf "%s-%s%s"
- , $^T
- , substr ( $hist, 1 - $HIST )
- , age_code ( $time )
- ;
- }
- return $res ;
- }
-
-sub put_state
- { my $STT = shift ;
- my $TMP = "$STT.tmp" ;
- open TMP, ">$TMP" or Error "can't write '$TMP' ($!)" ;
- for my $url ( sort keys %RES )
- { $RES { $url } [ 4 ]
- = check_hist $RES { $url } [ 0 ], $RES { $url } [ 4 ] ;
- my @OUT = @{ $RES { $url } } ;
- $OUT [ 1 ] =~ s/\s/_/g ;
+sub exp_date {
+ my @day = qw(Sun Mon Tue Wed Thu Fri Sat);
+ my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+ my @gmt = gmtime time + 3600;
+ sprintf "%s, %02d %s %4d %02d:%02d:%02d GMT", $day[ $gmt[6] ], $gmt[3],
+ $mon[ $gmt[4] ], $gmt[5] + 1900, @gmt[ 2, 1, 0 ];
+}
+sub find_conf {
+ return $opt{c} if $opt{c};
+ my $HOME = ( getpwuid $< )[7] or Error "can get homedir '$<' ($!)";
+ my @LIST = ( "$PRG.conf", "$HOME/.$PRG.conf", $DEF_CNF );
+ for my $conf (@LIST) { return $conf if -f $conf; }
+ Error sprintf "can't find a config file :\n %s", join "\n ", @LIST;
+}
+sub show_conf {
+ print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n";
+ for my $key ( sort keys %CNF ) {
+ next if $key =~ m/^_/;
+ print "show_conf : $key = '$CNF{$key}'\n";
+ }
+ for my $key ( sort keys %HREF ) {
+ printf "show_conf : for site '%s' use instead\n '%s'\n", $key,
+ $HREF{$key}
+ if $opt{v};
+ }
+ printf "show_conf : included '%s'\n", join "', '", @{ $CNF{_include} };
+ print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n";
+}
+sub get_conf;
+sub get_conf {
+ my $FILE = shift;
+ if ( grep $_ eq $FILE, @{ $CNF{_include} } ) {
+ Error "already included : '$FILE'";
+ }
+ else { push @{ $CNF{_include} }, $FILE; }
+ open FILE, $FILE or Error "can't open '$FILE' ($!)";
+ my $CONF = join "\n", grep /./, <FILE>;
+ close FILE;
+ $CONF =~ s/\t/ /g; # replace tabs
+ $CONF =~ s/^[+ ]+//; # delete leading space, plus
+ $CONF =~ s/\n\n\s+/ /g; # glue continuation lines
+ $CONF =~ s/\n\n\+\s+//g; # glue concatenation lines
+ $CONF =~ s/\n\n\./\n/g; # glue concatenation lines
+ chop $CONF;
+ print "--$CONF--\n" if $opt{d};
+ for ( grep !/^#/, split /\n\n/, $CONF ) {
+ 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')";
+ }
+ }
+}
+sub get_conf_opt {
+ my $err = '';
+ get_conf find_conf;
+ $CNF{timeout} = $opt{t} if $opt{t};
+ for my $key (@REQ_KEYS) {
+ unless ( exists $CNF{$key} ) {
+ $err .= "$prog error: missing config for '$key'\n";
+ }
+ }
+ for my $key (qw(min_poll max_poll max_sync min_sync)) {
+ my $max = $CNF{$key};
+ unless ( $max =~ /$TIM_PAT/o ) {
+ $err .= "$prog error: $key ($max) doesn't match /$TIM_PAT/\n";
+ }
+ }
+ unless ( grep $CNF{list_style} eq $_, @LIST_STYLE ) {
+ $err .= sprintf "%s : error: unknown 'list_style' '%s'\n", $prog,
+ $CNF{list_style};
+ }
+ unless ( grep $CNF{put_histo} eq $_, @PUT_HGRAM ) {
+ $err .= sprintf "%s : error: unknown 'put_histo' '%s'\n", $prog,
+ $CNF{put_histo};
+ }
+ if ( $opt{get} and not grep $opt{get} eq $_, @GET_OPTS ) {
+ $err .= sprintf "%s : error: unknown 'get option' '%s'\n", $prog,
+ $opt{get};
+ }
+ Error $err if $err;
+ $opt{q} = 0 if $opt{v};
+}
+sub tim_to_s {
+ my $tim = shift;
+ my %tab = ( 's' => 1, 'm' => 60, 'h' => 60 * 60, 'd' => 60 * 60 * 24 );
+ Error "wrong time '$tim'" unless $tim =~ /$TIM_PAT/o;
+ my $m = $1;
+ my $u = $2;
+ return $m * $tab{$u};
+}
+sub aprx_eq { my ( $t1, $t2 ) = @_; abs( $t1 - $t2 ) < 60; }
+sub aprx_ge { my ( $t1, $t2 ) = @_; $t1 > $t2 or aprx_eq $t1, $t2; }
+sub aprx_le { my ( $t1, $t2 ) = @_; $t1 < $t2 or aprx_eq $t1, $t2; }
+sub aprx_gt { my ( $t1, $t2 ) = @_; $t1 > $t2 and not aprx_eq $t1, $t2; }
+sub aprx_lt { my ( $t1, $t2 ) = @_; $t1 < $t2 and not aprx_eq $t1, $t2; }
+sub pr_interval {
+ my $s = shift;
+ my ( $magn, $unit );
+ my $mins = $s / 60;
+ my $m = int( $mins + 0.5 );
+ my $hours = $s / ( 60 * 60 );
+ my $h = int( $hours + 0.5 );
+ if ( $s < 50 ) { $magn = $s; $unit = 'second'; }
+ elsif ( $m < 50 ) { $magn = $m; $unit = 'minute'; }
+ elsif ( $h < 36 ) { $magn = $h; $unit = 'hour'; }
+ else { $magn = sprintf "%.1f", $hours / 24; $unit = 'day'; }
+ $unit .= 's' unless $magn == 1;
+ return "$magn $unit";
+}
+sub max_age1 {
+ ( tim_to_s $CNF {min_sync} ) + ( tim_to_s $CNF {max_poll} );
+}
+sub max_age2 {
+ ( tim_to_s $CNF {max_sync} ) + ( tim_to_s $CNF {max_poll} );
+}
+sub max_vrfy {
+ ( tim_to_s $CNF {min_poll} ) + ( tim_to_s $CNF {max_poll} );
+}
+sub age_code {
+ my $time = shift;
+ return 'z' unless $time =~ /^\d+$/;
+ return (
+ ( aprx_ge( $time, $^T - max_age1 ) )
+ ? 's'
+ : ( aprx_ge( $time, $^T - max_age2 ) ? 'b' : 'f' )
+ );
+}
+sub err {
+ my $url = shift;
+ my $stat = shift;
+ printf "*** %-10s %s\n", $stat, $url unless $opt{q};
+ my ( $time, $vrfy, $hstp, $hsts );
+ if ( exists $OLD{$url} ) {
+ $time = $OLD{$url}[0];
+ $vrfy = $OLD{$url}[2];
+ $hstp = substr $OLD{$url}[3], 1 - $HIST;
+ $hsts = $OLD{$url}[4];
+ }
+ else {
+ $time = 'undef';
+ $vrfy = 'undef';
+ $hstp = '';
+ $hsts = '';
+ }
+ $RES{$url} = [ $time, $stat, $vrfy, $hstp . 'f', $hsts, $^T ];
+}
+sub res {
+ my $url = shift;
+ my $time = shift;
+ my $stat = shift;
+ my $hstp = (
+ exists $OLD{$url}
+ ? substr( $OLD{$url}[3], 1 - $HIST )
+ : ''
+ );
+ my $hsts = ( exists $OLD{$url} ? $OLD{$url}[4] : '' );
+ printf "result %d %s\n", $time, $url if $opt{v};
+ $RES{$url} = [ $time, $stat, $^T, $hstp . 's', $hsts, $^T ];
+}
+sub get_state {
+ my $STT = shift;
+ open STT, $STT or Error "can't open '$STT' ($!)";
+ 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 ];
+ }
+ close STT;
+}
+sub check_hist {
+ my $time = shift;
+ my $hsts = shift;
+ printf "check_hist: last '$time' hsts '$hsts'\n" if $opt{d};
+ my $res = $hsts;
+ my ( $stmp, $hist );
+ if ( $hsts eq '' ) { $stmp = 0; $hist = ''; }
+ else { ( $stmp, $hist ) = split '-', $hsts; }
+ if ( aprx_le $stmp, $^T - tim_to_s '1d' ) {
+ $res = sprintf "%s-%s%s", $^T, substr( $hist, 1 - $HIST ),
+ age_code($time);
+ }
+ return $res;
+}
+sub put_state {
+ my $STT = shift;
+ my $TMP = "$STT.tmp";
+ open TMP, ">$TMP" or Error "can't write '$TMP' ($!)";
+ for my $url ( sort keys %RES ) {
+ $RES{$url}[4] = check_hist $RES {$url}[0], $RES{$url}[4];
+ my @OUT = @{ $RES{$url} };
+ $OUT[1] =~ s/\s/_/g;
git://git.exim.org / mirror-monitor.git / commitdiff
