PageRenderTime 56ms CodeModel.GetById 13ms app.highlight 38ms RepoModel.GetById 1ms app.codeStats 1ms

/swatch-3.2.3/lib/Swatch/Throttle.pm

#
Perl | 232 lines | 187 code | 27 blank | 18 comment | 12 complexity | ef0cf379d33f5701b38cfc098afb142a MD5 | raw file
  1package Swatch::Throttle;
  2require 5.000;
  3require Exporter;
  4
  5use strict;
  6use Carp;
  7use Date::Calc;
  8use Date::Manip;
  9
 10use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
 11
 12@ISA = qw(Exporter);
 13@EXPORT = qw/
 14  flushLogRecords
 15  throttle
 16  readHistory
 17  saveHistory
 18/;
 19$VERSION = '20030701';
 20
 21#
 22# %LogRecords = (
 23#          <string> =>  { # keyed by "key" below
 24#                       KEY => <string>, # generated key
 25#                       FIRST => @dmyhms,  # time of first log
 26#                       LAST => @dmyhms,   # time of last log
 27#                       COUNT => <int>,  # num of logs seen since last report
 28#                       },
 29#             );
 30my %LogRecords = ();
 31
 32
 33################################################################
 34sub readHistory {
 35  my $file = shift;
 36  my $return;
 37
 38  if (-f $file) {
 39    unless ($return = do $file) {
 40      warn "couldn't parse $file: $@" if $@;
 41      warn "couldn't do $file: $!" unless defined $return;
 42      warn "couldn't run file" unless $return;
 43    }
 44  }
 45  return;
 46}
 47
 48################################################################
 49sub saveHistory {
 50  my $file = shift;
 51  my $fh = new FileHandle $file, "w";
 52  my $date = localtime(time);
 53
 54  if (defined $fh) {
 55    $fh->print(q/
 56################################################################
 57# THIS FILE WAS GENERATED BY SWATCH AT $date.
 58# DO NOT EDIT!!!
 59################################################################
 60$Swatch::Throttle::LogRecords = (
 61/);
 62
 63    foreach my $key ( keys %LogRecords ) {
 64      $fh->print("\t'$key' => {\n");
 65      foreach my $attr ( keys %{ $LogRecords{$key} } ) {
 66	$fh->print("\t\t$attr => ");
 67	if ($attr =~ /FIRST|LAST|HOLD_DHMS/) {
 68	  $fh->print("[ ");
 69	  foreach my $elem (@{ $LogRecords{$key}{$attr} }) {
 70	    $fh->print("\'$elem\', ");
 71	  }
 72	  $fh->print("],\n");
 73        } else {
 74	  $fh->print("\"$LogRecords{$key}{$attr}\",\n");
 75	}
 76      }
 77      $fh->print("\t},\n");
 78    }
 79    $fh->print(");\n");
 80    $fh->close;
 81  } else {
 82  }
 83}
 84
 85################################################################
 86# throttle() - returns the 
 87################################################################
 88sub throttle {
 89  my %opts = (
 90	      MESSAGE       => $_,
 91	      EXTRA_CUTS => [],  # regex(s) used for creating key if key=log
 92	      KEY        => 'log',
 93	      TIME_FROM  => 'realtime',
 94	      TIME_REGEX => '^(\w{3}\s+\d{1,2}\s+\d{2}:\d{2}:\d{2})\s+', 
 95	      @_
 96	     );
 97
 98  my @dmyhms;
 99  my $key;
100  my $cur_rec;
101  my $msg = $opts{"MESSAGE"};
102
103  ## get the time ##
104  if ($opts{TIME_FROM} eq 'realtime') {
105    @dmyhms = Date::Calc::Today_and_Now();
106  } else {
107    if ($opts{MESSAGE} =~ /$opts{TIME_REGEX}/ and $1 ne '') {
108      my $date = Date::Calc::ParseDate($1);
109      if (not $date) {
110	warn "Cannot parse date from \"$opts{MESSAGE}\" using \"$opts{TIME_REGEX}\"\n";
111      } else {
112	@dmyhms = Date::Manip::UnixDate($date, "%Y", "%m", "%d", "%H", "%M", "%S");
113      }
114    }
115  }
116
117  ## get the key ##
118  if ($opts{KEY} eq 'log') {
119    $key = $opts{MESSAGE};
120    $key =~ s/$opts{TIME_REGEX}//;
121    if (defined $opts{EXTRA_CUTS}) {
122      foreach my $re (@{ $opts{EXTRA_CUTS} }) {
123	$key =~ s/$re//g;
124      }
125    }
126  } else {
127    $key = $opts{KEY};
128  }
129
130  ## just make the record if it doesn't exist yet ##
131  if (not defined $LogRecords{$key}) {
132    my $rec = ();
133    $rec->{KEY} = $key;
134    $rec->{FIRST} = [ @dmyhms ];
135    $rec->{LAST} = [ @dmyhms ];
136    $rec->{HOLD_DHMS} = $opts{HOLD_DHMS} if defined $opts{HOLD_DHMS};
137    $rec->{COUNT} = 1;
138    $LogRecords{$key} = $rec;
139    return $msg;
140  } else {
141    $cur_rec = $LogRecords{$key};
142    $cur_rec->{COUNT}++;
143    if (defined $opts{THRESHOLD} and $cur_rec->{COUNT} == $opts{THRESHOLD}) {
144      ## threshold exceeded ##
145      chomp $msg;
146      $msg = "$msg (threshold $opts{THRESHOLD} exceeded)";
147      $cur_rec->{COUNT} = 0;
148    } elsif (defined $opts{HOLD_DHMS} 
149	     and past_hold_time($cur_rec->{LAST},
150				\@dmyhms, $opts{HOLD_DHMS})) {
151      ## hold time exceeded ##
152      chomp $msg;
153      $msg = "$msg (seen $cur_rec->{COUNT} times)";
154      $cur_rec->{COUNT} = 0;
155      $cur_rec->{LAST} = [ @dmyhms ];
156    } else {
157      $msg = '';
158    }
159    $LogRecords{$key} = $cur_rec if exists($LogRecords{$key});  ## save any new values ##
160  }
161  return $msg;
162}
163
164################################################################
165# Checks to see if the current time is less than the last
166# time plus the minimum hold time.
167################################################################
168sub past_hold_time {
169  my $last = shift; ## pointer to YMDHMS array of last message
170  my $cur  = shift; ## pointer to YMDHMS array of current message
171  my $hold = shift; ## pointer to DHMS array of min. hold time
172
173  my @ymdhms = Date::Calc::Add_Delta_DHMS( @{ $last }, @{ $hold } );
174  my @delta = Date::Calc::Delta_DHMS( @ymdhms, @{ $cur } );
175  return(   $delta[0] > 0 or $delta[1] > 0
176	 or $delta[2] > 0 or $delta[3] > 0 );
177
178}
179
180################
181sub flushOldLogRecords {
182  my @dmyhms = Date::Calc::Today_and_Now();
183
184  foreach my $key (keys %LogRecords) {
185    if (defined $LogRecords{$key}->{HOLD_DHMS}) {
186      if (past_hold_time($LogRecords{$key}->{LAST}, \@dmyhms, $LogRecords{$key}->{HOLD_DHMS})
187	 and $LogRecords{$key}->{COUNT} == 0) {
188	delete($LogRecords{$key});
189      }
190    }
191  }
192}
193
194## The POD ###
195
196=head1 NAME
197
198  Swatch::Throttle - Perl extension for throttling and thresholding in swatch(1)
199
200=head1 SYNOPSIS
201
202  use Swatch::Throttle;
203
204  throttle(
205	   extra_cuts => @array_of_regular_expressions,
206	   hold_dhms => @DHMS,
207	   key => 'log'|<regex>|<user defined>,
208	   log_msg => <message>,
209	   threshold => <n>,
210	   time_from => 'realtime'|'timestamp',
211	   time_regex => <regex>,
212          );
213
214=head1 SWATCH SYNTAX
215
216  throttle threshold=<n>,\
217           delay=<hours>:<minutes>:<seconds>,\
218           key=log|regex|<regex>
219
220=head1 DESCRIPTION
221
222=head1 AUTHOR
223
224E. Todd Atkins, todd.atkins@stanfordalumni.org
225
226=head1 SEE ALSO
227
228perl(1), swatch(1).
229
230=cut
231  
2321;