Blocking Bad Robots

 package Apache::BlockAgent;
 # block browsers that we don't like
   
 use strict 'vars';
 use Apache::Constants ':common';
 use IO::File;
 my %MATCH_CACHE;
 my $DEBUG = 0;
   
 sub handler {
     my $r = shift;
       
     return DECLINED unless my $patfile = $r->dir_config('BlockAgentFile');
     return FORBIDDEN unless my $agent = $r->header_in('User-Agent');
     return SERVER_ERROR unless my $sub = get_match_sub($r,$patfile);
     return OK if $sub->($agent);
     $r->log_reason("Access forbidden to agent $agent",$r->filename);
     return FORBIDDEN;
 }
   
 # This routine creates a pattern matching subroutine from a
 # list of pattern matches stored in a file.
 sub get_match_sub {
     my ($r,$filename) = @_;
     my $mtime = -M $filename;
   
     # try to return the sub from cache
     return $MATCH_CACHE{$filename}->{'sub'} if
         $MATCH_CACHE{$filename} && 
             $MATCH_CACHE{$filename}->{'mod'} <= $mtime;
   
     # if we get here, then we need to create the sub
     return undef unless my $fh = new IO::File($filename);
     chomp(my @pats = <$fh>); # get the patterns into an array
     my $code = "sub { \$_ = shift;\n";
     foreach (@pats) {
         next if /^#/
         $code .= "return undef if /$_/i;\n";
     }
     $code .= "1; }\n";     
     warn $code if $DEBUG;
   
     # create the sub, cache and return it
     my $sub = eval $code;
     unless ($sub) {
         $r->log_error($r->uri,": ",$@);
         return undef;
     }
     @{$MATCH_CACHE{$filename}}{'sub','mod'}=($sub,$modtime);
     return $MATCH_CACHE{$filename}->{'sub'};
 }
   
 1;