lib/multithrottler/Throttler.pm

   1 ###########################################
   2 package Throttler;
   3 ###########################################
   4 use strict;
   5 use warnings;
   6 use Log::Log4perl qw(:easy);
   7
   8 our $VERSION    = "0.08";
   9 our $DB_VERSION = "1.1";
  10
  11 ###########################################
  12 sub new {
  13 ###########################################
  14     my($class, %options) = @_;
  15
  16     my $self = {
  17         db_version      => $DB_VERSION,
  18         backend         => "Memory",
  19         backend_options => {},
  20         reset           => 0,
  21         %options,
  22     };
  23
  24     if($self->{db_file}) {
  25         # legacy option, translate
  26         $self->{backend_options} = {
  27             db_file => $self->{db_file},
  28         };
  29         $self->{backend} = "YAML";
  30     }
  31
  32     my $backend_class = "Throttler::Backend::$self->{backend}";
  33
  34     $self->{db} = $backend_class->new(
  35             %{ $self->{backend_options} } );
  36
  37     $self->{changed} = 0;
  38
  39     bless $self, $class;
  40
  41     my $create = 1;
  42
  43     if( $self->{ db }->exists() ) {
  44         DEBUG "Backend store exists";
  45         $self->lock();
  46         $self->{data} = $self->{ db }->load();
  47
  48         $create = 0;
  49
  50         if($self->{data}->{chain} and
  51            ($self->{data}->{chain}->{max_items} != $options{max_items} or
  52             $self->{data}->{chain}->{interval} != $options{interval})) {
  53             $self->{changed} = 1;
  54             $create = 1;
  55         }
  56
  57         if($options{reset} or !$self->{ db }->backend_store_ok() ) {
  58             $create = 1;
  59         }
  60         $self->unlock();
  61     }
  62
  63     if($create) {
  64         $self->{ db }->create( \%options ) or
  65             LOGDIE "Creating backend store failed";
  66
  67           # create bucket chain
  68         $self->create( {
  69             max_items => $options{max_items},
  70             interval  => $options{interval},
  71         });
  72
  73         $self->{db}->save( $self->{data} );
  74     }
  75
  76     return $self;
  77 }
  78
  79 ###########################################
  80 sub create {
  81 ###########################################
  82     my($self, $options) = @_;
  83
  84     if( $self->{changed} ) {
  85         ERROR "Bucket chain parameters have changed ",
  86               "(max_items: $self->{data}->{chain}->{max_items}/",
  87               "$options->{max_items} ",
  88               "(interval: $self->{data}->{chain}->{interval}/",
  89               "$options->{interval})", ", throwing old chain away";
  90         $self->{changed} = 0;
  91     }
  92
  93     DEBUG "Creating bucket chain max_items=$options->{max_items} ",
  94           "interval=$options->{interval}";
  95
  96     $self->{data}->{chain} = Throttler::BucketChain->new(
  97             max_items => $options->{max_items},
  98             interval  => $options->{interval},
  99             );
 100 }
 101
 102 ###########################################
 103 sub lock {
 104 ###########################################
 105     my($self) = @_;
 106     DEBUG "Trying to get lock ($$)";
 107     $self->{db}->lock();
 108     DEBUG "Lock on ($$)";
 109 }
 110
 111 ###########################################
 112 sub unlock {
 113 ###########################################
 114     my($self) = @_;
 115     DEBUG "Lock off";
 116     $self->{db}->unlock();
 117 }
 118
 119 ###########################################
 120 sub current_value {
 121 ###########################################
 122     my($self, %options) = @_;
 123
 124     $self->{data} = $self->{db}->load();
 125     my $ret = $self->{data}->{chain}->current_value(%options);
 126
 127     return $ret;
 128 }
 129
 130 ###########################################
 131 sub try_push {
 132 ###########################################
 133     my($self, %options) = @_;
 134
 135     if(exists $options{key}) {
 136         DEBUG "Pushing key $options{key}";
 137     } else {
 138         DEBUG "Pushing keyless item";
 139     }
 140
 141     $self->lock();
 142
 143     $self->{data} = $self->{db}->load();
 144     my $ret = $self->{data}->{chain}->try_push(%options);
 145     $self->{db}->save( $self->{data} );
 146
 147     $self->unlock();
 148     return $ret;
 149 }
 150
 151 ###########################################
 152 sub reset_key {
 153 ###########################################
 154     my($self, %options) = @_;
 155
 156     if(exists $options{key}) {
 157         DEBUG "Resetting count for $options{key}";
 158     } else {
 159         DEBUG "Resetting count for keyless item";
 160     }
 161
 162     $self->lock();
 163
 164     $self->{data} = $self->{db}->load();
 165     my $ret = $self->{data}->{chain}->reset_key(%options);
 166     $self->{db}->save( $self->{data} );
 167
 168     $self->unlock();
 169     return $ret;
 170 }
 171
 172 ###########################################
 173 sub buckets_dump {
 174 ###########################################
 175     my($self) = @_;
 176     $self->lock();
 177     $self->{data} = $self->{db}->load();
 178     my $ret = $self->{data}->{chain}->as_string();
 179     $self->unlock();
 180     return $ret;
 181 }
 182
 183 ###########################################
 184 sub buckets_rotate {
 185 ###########################################
 186     my($self) = @_;
 187     my $ret = $self->{data}->{chain}->rotate();
 188     return $ret;
 189 }
 190
 191 package Throttler::Range;
 192
 193 ###########################################
 194 sub new {
 195 ###########################################
 196     my($class, $start, $stop) = @_;
 197
 198     my $self = {
 199         start => $start,
 200         stop  => $stop,
 201     };
 202     bless $self, $class;
 203 }
 204
 205 ###########################################
 206 sub min {
 207 ###########################################
 208     my($self) = @_;
 209     return $self->{start};
 210 }
 211
 212 ###########################################
 213 sub max {
 214 ###########################################
 215     my($self) = @_;
 216     return $self->{stop};
 217 }
 218
 219 ###########################################
 220 sub member {
 221 ###########################################
 222     my($self, $time) = @_;
 223
 224     return ($time >= $self->{start} and $time <= $self->{stop});
 225 }
 226
 227 ###########################################
 228 package Throttler::BucketChain;
 229 ###########################################
 230 use Log::Log4perl qw(:easy);
 231
 232 our $DEFAULT_KEY = "_default";
 233
 234 ###########################################
 235 sub new {
 236 ###########################################
 237     my($class, %options) = @_;
 238
 239     my $self = {
 240         max_items => undef,
 241         interval  => undef,
 242         %options,
 243     };
 244
 245     if(!$self->{max_items} or
 246        !$self->{interval}) {
 247         LOGDIE "Both max_items and interval need to be defined";
 248     }
 249
 250     if(!$self->{nof_buckets}) {
 251         $self->{nof_buckets} = 10;
 252     }
 253
 254     if($self->{nof_buckets} > $self->{interval}) {
 255         $self->{nof_buckets} = $self->{interval};
 256     }
 257
 258     bless $self, $class;
 259
 260     $self->reset();
 261
 262     return $self;
 263 }
 264
 265 ###########################################
 266 sub reset {
 267 ###########################################
 268     my($self) = @_;
 269
 270     $self->{buckets} = [];
 271
 272     my $bucket_time_span = int ($self->{interval} /
 273                                 $self->{nof_buckets});
 274
 275     $self->{bucket_time_span} = $bucket_time_span;
 276
 277     my $time_start = time() -
 278         ($self->{nof_buckets}-1) * $bucket_time_span;
 279
 280     for(1..$self->{nof_buckets}) {
 281         my $time_end = $time_start + $bucket_time_span - 1;
 282         DEBUG "Creating bucket ", hms($time_start), " - ", hms($time_end);
 283         push @{$self->{buckets}}, {
 284             time  => Throttler::Range->new($time_start, $time_end),
 285             count => {},
 286         };
 287         $time_start = $time_end + 1;
 288     }
 289
 290     $self->{head_bucket_idx} = 0;
 291     $self->{tail_bucket_idx} = $#{$self->{buckets}};
 292 }
 293
 294 ###########################################
 295 sub first_bucket {
 296 ###########################################
 297     my($self) = @_;
 298
 299     $self->{current_idx} = $self->{head_bucket_idx};
 300     return $self->{buckets}->[ $self->{current_idx} ];
 301 }
 302
 303 ###########################################
 304 sub last_bucket {
 305 ###########################################
 306     my($self) = @_;
 307
 308     $self->{current_idx} = $self->{tail_bucket_idx};
 309     return $self->{buckets}->[ $self->{current_idx} ];
 310 }
 311
 312 ###########################################
 313 sub next_bucket {
 314 ###########################################
 315     my($self) = @_;
 316
 317     return undef if $self->{current_idx} == $self->{tail_bucket_idx};
 318
 319     $self->{current_idx}++;
 320     $self->{current_idx} = 0 if $self->{current_idx} > $#{$self->{buckets}};
 321
 322     return $self->{buckets}->[ $self->{current_idx} ];
 323 }
 324
 325 ###########################################
 326 sub as_string {
 327 ###########################################
 328     my($self) = @_;
 329
 330     my @t;
 331     push @t, ["#", "idx", ("Time: " . hms(time)), "Key", "Count"];
 332
 333     my $count = 1;
 334
 335     for(my $b = $self->first_bucket(); $b; $b = $self->next_bucket()) {
 336         my $span = hms($b->{time}->min) . " - " . hms($b->{time}->max);
 337         my $idx  = $self->{current_idx};
 338         my $count_string = $count;
 339
 340         if(! scalar keys %{$b->{count}}) {
 341             push @t, [$count_string, $idx, $span, "", ""];
 342         }
 343
 344         foreach my $key (sort keys %{$b->{count}}) {
 345             push @t, [$count_string, $idx, $span, $key, $b->{count}->{$key}];
 346             $span = "";
 347             $count_string = "";
 348             $idx = "";
 349         }
 350
 351         $count++;
 352     }
 353     return join('', map {"$_\n"} map {join "\t", @$_} @t);
 354 }
 355
 356 ###########################################
 357 sub hms {
 358 ###########################################
 359     my($time) = @_;
 360
 361     my ($sec,$min,$hour) = localtime($time);
 362     return sprintf "%02d:%02d:%02d",
 363            $hour, $min, $sec;
 364 }
 365
 366 ###########################################
 367 sub bucket_add {
 368 ###########################################
 369     my($self, $time) = @_;
 370
 371       # ... and append a new one at the end
 372     my $time_start = $self->{buckets}->
 373                       [$self->{tail_bucket_idx}]->{time}->max + 1;
 374     my $time_end   = $time_start + $self->{bucket_time_span} - 1;
 375
 376     DEBUG "Adding bucket: ", hms($time_start), " - ", hms($time_end);
 377
 378     $self->{tail_bucket_idx}++;
 379     $self->{tail_bucket_idx} = 0 if $self->{tail_bucket_idx} >
 380                                     $#{$self->{buckets}};
 381     $self->{head_bucket_idx}++;
 382     $self->{head_bucket_idx} = 0 if $self->{head_bucket_idx} >
 383                                     $#{$self->{buckets}};
 384
 385     $self->{buckets}->[ $self->{tail_bucket_idx} ] = {
 386           time  => Throttler::Range->new($time_start, $time_end),
 387           count => {},
 388     };
 389 }
 390
 391 ###########################################
 392 sub rotate {
 393 ###########################################
 394     my($self, $time) = @_;
 395     $time = time() unless defined $time;
 396
 397     # If the last bucket handles a time interval that doesn't cover
 398     # $time, we need to rotate the bucket brigade. The first bucket
 399     # will be cleared and re-used as the new last bucket of the chain.
 400
 401     DEBUG "Rotating buckets time=", hms($time), " ",
 402           "head=", $self->{head_bucket_idx};
 403
 404     if($self->last_bucket->{time}->{stop} >= $time) {
 405         # $time is still covered in the bucket brigade, we're golden
 406         DEBUG "Rotation not necessary (",
 407               hms($self->last_bucket->{time}->{stop}),
 408               " - ", hms($time), ")";
 409         return 1;
 410     }
 411
 412       # If we're too far off, just dump all buckets and re-init
 413     if($self->{buckets}->[ $self->{tail_bucket_idx} ]->{time}->max <
 414        $time - $self->{interval}) {
 415         DEBUG "Too far off, resetting (", hms($time), " >> ",
 416               hms($self->{buckets}->[ $self->{head_bucket_idx} ]->{time}->min),
 417               ")";
 418         $self->reset();
 419         return 1;
 420     }
 421
 422     while($self->last_bucket()->{time}->min <= $time) {
 423         $self->bucket_add();
 424     }
 425
 426     DEBUG "After rotation: ",
 427           hms($self->{buckets}->[ $self->{head_bucket_idx} ]->{time}->min),
 428           " - ",
 429           hms($self->{buckets}->[ $self->{tail_bucket_idx} ]->{time}->max),
 430           " (covers ", hms($time), ")";
 431 }
 432
 433 ###########################################
 434 sub bucket_find {
 435 ###########################################
 436     my($self, $time) = @_;
 437
 438     DEBUG "Searching bucket for time=", hms($time);
 439
 440         # Search in the newest bucket first, chances are it's there
 441     my $last_bucket = $self->last_bucket();
 442     if($last_bucket->{time}->member($time)) {
 443         DEBUG hms($time), " covered by last bucket";
 444         return $last_bucket;
 445     }
 446
 447     for(my $b = $self->first_bucket(); $b; $b = $self->next_bucket()) {
 448         if($b->{time}->member($time)) {
 449             DEBUG "Found bucket ", hms($b->{time}->min),
 450                   " - ", hms($b->{time}->max);
 451             return $b;
 452         }
 453     }
 454
 455     DEBUG "No bucket found for time=", hms($time);
 456     return undef;
 457 }
 458
 459 ###########################################
 460 sub current_value {
 461 ###########################################
 462     my($self, %options) = @_;
 463
 464     my $key = $DEFAULT_KEY;
 465     $key = $options{key} if defined $options{key};
 466
 467     DEBUG "Getting current value for key=", $key;
 468
 469     my $val = 0;
 470
 471     for(0..$#{$self->{buckets}}) {
 472         $val += $self->{buckets}->[$_]->{count}->{$key} if
 473                 exists $self->{buckets}->[$_]->{count}->{$key};
 474     }
 475
 476     return $val;
 477 }
 478
 479 ###########################################
 480 sub try_push {
 481 ###########################################
 482     my($self, %options) = @_;
 483
 484     my $key = $DEFAULT_KEY;
 485     $key = $options{key} if defined $options{key};
 486
 487     my $time = time();
 488     $time = $options{time} if defined $options{time};
 489
 490     my $count = 1;
 491     $count = $options{count} if defined $options{count};
 492
 493     my $force = 0;
 494     $force = $options{force} if defined $options{force};
 495
 496     DEBUG "Trying to push $key ", hms($time), " $count";
 497
 498     my $b = $self->bucket_find($time);
 499
 500     if(!$b) {
 501        $self->rotate($time);
 502        $b = $self->bucket_find($time);
 503     }
 504
 505     # Determine the total count for this key
 506     my $val = $self->current_value(%options);
 507
 508     if($val >= $self->{max_items}) {
 509         if ($force) {
 510             DEBUG "Increasing (force) counter $key by $count ",
 511                   "($val|$self->{max_items})";
 512             $b->{count}->{$key} += $count;
 513         } else {
 514             DEBUG "Not increasing counter $key by $count (already at max)";
 515         }
 516         return 0;
 517     } else {
 518         DEBUG "Increasing counter $key by $count ",
 519               "($val|$self->{max_items})";
 520         $b->{count}->{$key} += $count;
 521         return 1;
 522     }
 523
 524     LOGDIE "Time $time is outside of bucket range\n", $self->as_string;
 525     return undef;
 526 }
 527
 528 ###########################################
 529 sub reset_key {
 530 ###########################################
 531     my ($self, %options) = @_;
 532
 533     my $key = $DEFAULT_KEY;
 534     $key = $options{key} if defined $options{key};
 535
 536     DEBUG "Resetting $key";
 537
 538     my $total = 0;
 539     for(0..$#{$self->{buckets}}) {
 540         if (exists $self->{buckets}->[$_]->{count}->{$key}) {
 541             $total += $self->{buckets}->[$_]->{count}->{$key};
 542             $self->{buckets}->[$_]->{count}->{$key} = 0;
 543         }
 544     }
 545
 546     return $total;
 547 }
 548
 549 ###########################################
 550 package Throttler::Backend::Base;
 551 ###########################################
 552
 553 ###########################################
 554 sub new {
 555 ###########################################
 556     my($class, %options) = @_;
 557
 558     my $self = {
 559         %options,
 560     };
 561
 562     bless $self, $class;
 563     $self->init();
 564     return $self;
 565 }
 566
 567 sub exists { 0 }
 568 sub create { 1 }
 569 #sub save   { }
 570 #sub load   { }
 571 sub init   { }
 572 sub lock   { }
 573 sub unlock { }
 574 sub backend_store_ok { 1 }
 575
 576 ###########################################
 577 package Throttler::Backend::Memory;
 578 ###########################################
 579 use base 'Throttler::Backend::Base';
 580
 581 ###########################################
 582 sub save {
 583 ###########################################
 584     my($self, $data) = @_;
 585     $self->{data} = $data;
 586 }
 587
 588 ###########################################
 589 sub load {
 590 ###########################################
 591     my($self) = @_;
 592     return $self->{data};
 593 }
 594
 595 ###########################################
 596 package Throttler::Backend::YAML;
 597 ###########################################
 598 use base 'Throttler::Backend::Base';
 599 use Log::Log4perl qw(:easy);
 600 use Fcntl qw(:flock);
 601
 602 ###########################################
 603 sub init {
 604 ###########################################
 605     my($self) = @_;
 606
 607     require YAML;
 608     $YAML::LoadBlessed = 1;
 609 }
 610
 611 ###########################################
 612 sub backend_store_ok {
 613 ###########################################
 614     my($self) = @_;
 615
 616     # Legacy instances used DBM::Deep, but those data stores will be
 617     # replaced by YAML backends. If we reuse a backend data store, make
 618     # sure it's a YAML file and not a DBM::Deep blob.
 619     if(! -f $self->{db_file} ) {
 620         return 1;
 621     }
 622
 623     eval {
 624         $self->load();
 625     };
 626
 627     if($@) {
 628         ERROR "$self->{db_file} apparently isn't a YAML file, we'll ",
 629               "have to dump it and rebuild the bucket chain in YAML";
 630         return 0;
 631     }
 632
 633     return 1;
 634 }
 635
 636 ###########################################
 637 sub exists {
 638 ###########################################
 639     my($self) = @_;
 640
 641     return -f $self->{db_file};
 642 }
 643
 644 ###########################################
 645 sub save {
 646 ###########################################
 647     my($self, $data) = @_;
 648
 649     DEBUG "Saving YAML file $self->{db_file}";
 650     YAML::DumpFile( $self->{db_file}, $data );
 651 }
 652
 653 ###########################################
 654 sub load {
 655 ###########################################
 656     my($self) = @_;
 657
 658     DEBUG "Loading YAML file $self->{db_file}";
 659     return YAML::LoadFile( $self->{db_file} );
 660 }
 661
 662 ###########################################
 663 sub lock {
 664 ###########################################
 665     my($self) = @_;
 666
 667     open $self->{fh}, "+<", $self->{db_file} or
 668         LOGDIE "Can't open $self->{db_file} for locking: $!";
 669     flock $self->{fh}, LOCK_EX;
 670 }
 671
 672 ###########################################
 673 sub unlock {
 674 ###########################################
 675     my($self) = @_;
 676     flock $self->{fh}, LOCK_UN;
 677 }
 678
 679 1;
 680
 681 __END__
 682
 683 =head1 NAME
 684
 685 Throttler - Limit data throughput
 686
 687 =head1 SYNOPSIS
 688
 689     use Throttler;
 690
 691     ### Simple: Limit throughput to 100 per hour
 692
 693     my $throttler = Throttler->new(
 694         max_items => 100,
 695         interval  => 3600,
 696     );
 697
 698     if($throttler->try_push()) {
 699         print "Item can be pushed\n";
 700     } else {
 701         print "Item needs to wait\n";
 702     }
 703
 704     ### Advanced: Use a persistent data store and throttle by key:
 705
 706     my $throttler = Throttler->new(
 707         max_items => 100,
 708         interval  => 3600,
 709         backend   => "YAML",
 710         backend_options => {
 711             db_file => "/tmp/mythrottle.yml",
 712         },
 713     );
 714
 715     if($throttler->try_push(key => "somekey")) {
 716         print "Item can be pushed\n";
 717     }
 718
 719 =head1 DESCRIPTION
 720
 721 C<Throttler> helps solving throttling tasks like "allow a single
 722 IP only to send 100 emails per hour". It provides an optionally persistent
 723 data store to keep track of what happened before and offers a simple
 724 yes/no interface to an application, which can then focus on performing
 725 the actual task (like sending email) or suppressing/postponing it.
 726
 727 When defining a throttler, you can tell it to keep its
 728 internal data structures in memory:
 729
 730       # in-memory throttler
 731     my $throttler = Throttler->new(
 732         max_items => 100,
 733         interval  => 3600,
 734     );
 735
 736 However, if the data structures need to be maintained across different
 737 invocations of a script or several instances of scripts using the
 738 throttler, using a persistent database is required:
 739
 740       # persistent throttler
 741     my $throttler = Throttler->new(
 742         max_items => 100,
 743         interval  => 3600,
 744         backend   => "YAML",
 745         backend_options => {
 746             db_file => "/tmp/mythrottle.yml",
 747         },
 748     );
 749
 750 The call above will reuse an existing backend store, given that the
 751 C<max_items> and C<interval> settings are compatible and leave the
 752 stored counter bucket chain contained therein intact. To specify that
 753 the backend store should be rebuilt and all counters be reset, use
 754 the C<reset =E<gt> 1> option of the Throttler object constructor.
 755
 756 In the simplest case, C<Throttler> just keeps track of single
 757 events. It allows a certain number of events per time frame to succeed
 758 and it recommends to block the rest:
 759
 760     if($throttler->try_push()) {
 761         print "Item can be pushed\n";
 762     } else {
 763         print "Item needs to wait\n";
 764     }
 765
 766 the C<force =E<gt> 1> option of the try_push() method will cause the
 767 counter to be incremented regardless of threshold for use in scenarios
 768 where max_items is a threshold rather than throttle condition:
 769
 770     if($throttler->try_push('force' => 1)) {
 771         print "Item can be pushed\n";
 772     } else {
 773         print "Counter incremented, Item needs to wait\n";
 774     }
 775
 776 When throttling different categories of items, like attempts to send
 777 emails by IP address of the sender, a key can be used:
 778
 779     if($throttler->try_push( key => "192.168.0.1" )) {
 780         print "Item can be pushed\n";
 781     } else {
 782         print "Item needs to wait\n";
 783     }
 784
 785 In this case, each key will be tracked separately, even if the quota
 786 for one key is maxed out, other keys will still succeed until their
 787 quota is reached.
 788
 789 =head2 HOW IT WORKS
 790
 791 To keep track of what happened within the specified time frame,
 792 C<Throttler> maintains a round-robin data store, either in
 793 memory or on disk. It splits up the controlled time interval into
 794 buckets and maintains counters in each bucket:
 795
 796     1 hour ago                     Now
 797       +-----------------------------+
 798       | 3  | 7  | 0  | 0  | 4  | 1  |
 799       +-----------------------------+
 800        4:10 4:20 4:30 4:40 4:50 5:00
 801
 802 To decide whether to allow a new event to happen or not, C<Throttler>
 803 adds up all counters (3+7+4+1 = 15) and then compares the result
 804 to the defined threshold. If the event is allowed, the corresponding
 805 counter is increased (last column):
 806
 807     1 hour ago                     Now
 808       +-----------------------------+
 809       | 3  | 7  | 0  | 0  | 4  | 2  |
 810       +-----------------------------+
 811        4:10 4:20 4:30 4:40 4:50 5:00
 812
 813 While time progresses, old buckets are expired and then reused
 814 for new data. 10 minutes later, the bucket layout would look like this:
 815
 816     1 hour ago                     Now
 817       +-----------------------------+
 818       | 7  | 0  | 0  | 4  | 2  | 0  |
 819       +-----------------------------+
 820        4:20 4:30 4:40 4:50 5:00 5:10
 821
 822 =head2 LOCKING
 823
 824 When used with a persistent data store, C<Throttler> protects
 825 competing applications from clobbering the database by using the locking
 826 mechanism offered with C<DBM::Deep>. Both the C<try_push()> and the
 827 C<buckets_dump> function already perform locking behind the scenes.
 828
 829 If you see a need to lock the data store yourself, i.e. when trying to
 830 push counters for several keys simultaneously, use
 831
 832     $throttler->lock();
 833
 834 and
 835
 836     $throttler->unlock();
 837
 838 to protect the data store against competing applications.
 839
 840 =head2 RESETTING
 841
 842 Sometimes, you may need to reset a specific counter, e.g. if an IP
 843 address has been unintentionally throttled:
 844
 845     my $count = $throttler->reset_key(key => "192.168.0.1");
 846
 847 The C<reset_key> method returns the total number of attempts so far.
 848
 849 =head2 ADVANCED USAGE
 850
 851 By default, C<Throttler> will decide on the number of buckets by
 852 dividing the time interval by 10. It won't handle sub-seconds, though,
 853 so if the time interval is less then 10 seconds, the number of buckets
 854 will be equal to the number of seconds in the time interval.
 855
 856 If the default bucket allocation is unsatisfactory, you can specify
 857 it yourself:
 858
 859     my $throttler = Throttler->new(
 860         max_items   => 100,
 861         interval    => 3600,
 862         nof_buckets => 42,
 863     );
 864
 865 Mainly for debugging and testing purposes, you can specify a different
 866 time than I<now> when trying to push an item:
 867
 868     if($throttler->try_push(
 869           key  => "somekey",
 870           time => time() - 600 )) {
 871         print "Item can be pushed in the past\n";
 872     }
 873
 874 Also for debugging and testing purposes, you can obtain the current
 875 value of an item:
 876
 877     my $val = $throttler->current_value(key => "somekey");
 878
 879 Speaking of debugging, there's a utility method C<buckets_dump> which
 880 returns a string containing lines with tab-separated cells in them
 881 representing what's in each bucket.
 882
 883 So the code
 884
 885     use Throttler;
 886
 887     my $throttler = Throttler->new(
 888         interval  => 3600,
 889         max_items => 10,
 890     );
 891
 892     $throttler->try_push(key => "foobar");
 893     $throttler->try_push(key => "foobar");
 894     $throttler->try_push(key => "barfoo");
 895     print $throttler->buckets_dump();
 896
 897 will print out something like
 898
 899         #       idx     Time: 14:43:00  Key     Count
 900         1       0       13:49:00 - 13:54:59
 901         2       1       13:55:00 - 14:00:59
 902         3       2       14:01:00 - 14:06:59
 903         4       3       14:07:00 - 14:12:59
 904         5       4       14:13:00 - 14:18:59
 905         6       5       14:19:00 - 14:24:59
 906         7       6       14:25:00 - 14:30:59
 907         8       7       14:31:00 - 14:36:59
 908         9       8       14:37:00 - 14:42:59
 909         10      9       14:43:00 - 14:48:59     barfoo  1
 910                                 foobar  2
 911
 912 and allow for further investigation.
 913
 914 =head1 LICENSE
 915
 916 Copyright 2007 by Mike Schilli, all rights reserved.
 917 This program is free software, you can redistribute it and/or
 918 modify it under the same terms as Perl itself.
 919
 920 =head1 AUTHOR
 921
 922 2007, Mike Schilli <cpan@perlmeister.com>