package Apache::BlockAgent;
   
use strict;
use Apache::Constants qw(:common);
use Apache::File ();
use Apache::Log ();
use Safe ();

my $Safe = Safe->new;
my %MATCH_CACHE;

sub handler {
    my $r = shift;
    my($patfile, $agent, $sub);
    return DECLINED unless $patfile = $r->dir_config('BlockAgentFile');
    return FORBIDDEN unless $agent = $r->header_in('User-Agent');
    return SERVER_ERROR unless $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) = @_;
    $filename = $r->server_root_relative($filename);
    my $mtime = (stat $filename)[9];
    
    # 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
    my($fh, @pats);
    return unless $fh = Apache::File->new($filename);
    chomp(@pats = <$fh>); # get the patterns into an array
    my $code = "sub { local \$_ = shift;\n";
    foreach (@pats) {
	next if /^#/;
	$code .= "return if /$_/i;\n";
    }
    $code .= "1; }\n";     
    $r->server->log->debug("compiled $filename into:\n $code");

    # create the sub, cache and return it
    ($code) = $code =~ /^(.*)$/s; #untaint
    my $sub = $Safe->reval($code);
    unless ($sub) {
	$r->log_error($r->uri, ": ", $@);
	return;
    }
    @{ $MATCH_CACHE{$filename} }{'sub','mod'} = ($sub, $mtime);
    return $MATCH_CACHE{$filename}->{'sub'};
}

1;
__END__