Herzlich willkommen im Archiv vom ABAKUS Online Marketing Forum
Du befindest Dich im Archiv vom ABAKUS Online Marketing Forum. Hier kannst Du Dich für das Forum mit den aktuellen Beiträgen registrieren.
Code: Alles auswählen
package KFSW::AccessControl;
use strict;
use warnings;
use IPC::ShareLite;
use Fcntl qw(:flock);
use Storable qw(freeze thaw);
our $VERSION = '0.01';
sub new{
my $pkg = shift;
my %param = @_;
my $self = {};
bless $self,ref $pkg || $pkg;
my $params = {};
%{$params} = ('ctrl_time' => 60,
'max_hits' => 60,
'cache_key' => 'KFSWAccessControl',
'clean' => 1000 );
$self->{'params'} = $params;
_parse_params(\%param);
return $self;
}
sub _init{
my $self = shift;
$self->{'_share'} = new IPC::ShareLite( -key => $self->{'params'}->{'cache_key'},
-create => 'yes',
-destroy => 'no' ) or die $!;
return unless defined wantarray;
return $self->{'_share'};
}
sub _parse_params{
my $self = shift;
my $params = shift;
my ($opt_key,$opt_val,$opt);
while(($opt_key,$opt_val) = each %{$params}){
unless($opt_val){
die('KFSW::AccessControl->new() called with odd number of option parameters' .
' - should be of the form option => value');
}
$opt = lc($opt_key);
$opt =~ s/^-|_//g;
if(exists $self->{'params'}->{$opt}){
$self->{'params'}->{$opt} = $opt_val
}
}
return unless defined wantarray;
return 1;
}
sub request_allowed{
my $self = shift;
my $ip = shift || '';
return undef unless(length($ip));
my $nr = $self->request_nr($ip);
return unless defined wantarray;
return ($nr < $self->{'params'}->{'max_hits'})? 1 : 0;
}
sub request_nr{
my $self = shift;
my $ip = shift || '';
return undef unless(length($ip));
my $share = $self->{'_share'} || $self->_init();
$share->lock(LOCK_EX);
my $is_time = time();
my $off_time = time() + $self->{'params'}->{'ctrl_time'};
my $del_time = time() - $self->{'params'}->{'ctrl_time'};
my $share_data;
my $data = $share->fetch() || '';
if(length($data)){
$share_data = thaw($data);
}else{
$share_data = {};
}
$share_data->{'hits'}++;
$share_data->{$ip} = {} unless(exists $share_data->{$ip});
$share_data->{$ip}->{'last_request'} = $is_time;
$share_data->{$ip}->{'requests'} = [] unless(exists $share_data->{$ip}->{'requests'});
if(scalar(@{$share_data->{$ip}->{'requests'}})){
@{$share_data->{$ip}->{'requests'}} = grep { $is_time <= $_ } @{$share_data->{$ip}->{'requests'}};
}
push(@{$share_data->{$ip}->{'requests'}}, $off_time);
unless($share_data->{'hits'} % $self->{'params'}->{'clean'}){ # clean memory each 1000 requests
foreach my $key(keys %{$share_data}){
next if($key eq 'hits');
if(defined($share_data->{$key}->{'last_request'}) && ($share_data->{$key}->{'last_request'} < $del_time)){
$share_data->{$key} = undef;
delete $share_data->{$key};
}
}
}
$share->store(freeze($share_data));
$share->unlock();
return unless defined wantarray;
return scalar(@{$share_data->{$ip}->{'requests'}});
}
# Preloaded methods go here.
1;
__END__
# Below is stub documentation for your module. You'd better edit it!
=head1 NAME
KFSW::AccessControl - Perl extension for controling access to perlscripts runing as CGI, FCGI or under mod_perl.
=head1 SYNOPSIS
use KFSW::AccessControl;
my $control = new KFSW::AccessControl('-ctrl_time' => 60,
'-max_hits' => 60);
my $ip_addr = $ENV{'REMOTE_ADDR'} or '';
my $req_in_time = $control->request_nr($ip_addr) if(length($ip_addr));
my $req_allowed = $control->request_allowed($ip_addr) if(length($ip_addr));
=head1 DESCRIPTION
ToDo...
=head2 EXPORT
None.
=head1 SEE ALSO
ToDo...
=head1 AUTHOR
Kristian Fischer, E<lt>me@kfsw.deE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2008 by Kristian Fischer
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.5 or,
at your option, any later version of Perl 5 you may have available.
=cut
Ja, das ist korrekt.PS: bei deinem RewriteCond fällt mir auf dass die nicht wirklich perfekt sind.
