view release on metacpan or  search on metacpan

lib/Algorithm/FloodControl.pm  view on Meta::CPAN

package Algorithm::FloodControl;

use strict;
use warnings;
use utf8;
use 5.008000;

use Carp;
use Params::Validate qw/:all/;
use base 'Class::Accessor::Fast';
use Exporter 'import';
use Module::Load;

use version; our $VERSION = qv("2.01")->numify;
our @EXPORT = qw(
  flood_check
  flood_storage
);

# $Id: FloodControl.pm 7 2008-11-06 12:51:33Z gugu $
# $Source$
# $HeadURL: file:///var/svn/Algorithm-FloodControl/lib/Algorithm/FloodControl.pm $

__PACKAGE__->mk_accessors(qw/backend_name storage limits/);

my %FLOOD = ();

sub flood_check {
    my $fc = shift;    # max flood events count
    my $fp = shift;    # max flood time period for $fc events
    my $en = shift;    # event name (key) which identifies flood check data

    if ( !$en ) {
        my ( $p, $f, $l ) = caller;    # construct event name by:
        $en = "$p:$f:$l";              # package + filename + line
                                       # print STDERR "EN: $en\n";
    }

    $FLOOD{$en} ||= [];                # make empty flood array for this event name
    my $ar = $FLOOD{$en};              # get array ref for event's flood array
    my $ec = @{$ar};                   # events count in the flood array

    if ( $ec >= $fc ) {

        # flood array has enough events to do real flood check
        my $ot = $ar->[0];             # oldest event timestamp in the flood array
        my $tp = time() - $ot;         # time period between current and oldest event

        # now calculate time in seconds until next allowed event
        my $wait = int( ( $ot + ( $ec * $fp / $fc ) ) - time() );
        if ( $wait > 0 ) {

            # positive number of seconds means flood in progress
            # event should be rejected or postponed
            # print "WARNING: next event will be allowed in $wait seconds\n";
            return $wait;
        }

        # negative or 0 seconds means that event should be accepted
        # oldest event is removed from the flood array
        shift @{$ar};
    }

    # flood array is not full or oldest event is already removed
    # so current event has to be added