#! /usr/bin/perl -w

#
# A domain and url collector robot for squidGuard
#
# By Pl Baltzersen 1999-2000 (pal.baltzersen@ost.eltele.no)
# Based on earlier work by Lars Erik Hland (leh@nimrod.no)
#
# The current version may be found anytime at:
# http://ftp.ost.eltele.no/pub/www/proxy/squidGuard/contrib/squidGuardRobot/
#

# By accepting this notice, you agree to be bound by the following
# agreements:
# 
# This software product, squidGuardRobot, is copyrighted (C) 2000 by
# ElTele st AS, Oslo, Norway, with all rights reserved.
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License (version 2) as
# published by the Free Software Foundation.  It is distributed in the
# hope that it will be useful, but WITHOUT ANY WARRANTY; without even
# the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
# PURPOSE.  See the GNU General Public License (GPL) for more details.
# 
# You should have received a copy of the GNU General Public License
# (GPL) along with this program.

my $VERSION = "2.0.9";

my ($debug,$verbose,$quiet,$umask,$home,$lib,$etc,$source_proxy,$link_proxy);
my ($simultaneous_sources,$simultaneous_links,$bulk,$fake_user_agent);
my ($sources,$source_timeout,$source_retries,$candidates);
my ($source_bouncing_ttl,$source_remember,$source_min_ttl,$source_max_ttl);
my ($links,$link_timeout,$link_retries,);
my ($link_bouncing_ttl,$link_remember,$link_min_ttl,$link_max_ttl);
my ($domainexceptions,$urlexceptions,$exceptions,$includes,$redirectors,$patterns);
my ($domainlist,$newdomains,$domains,$domain_ttl,$urllist,$newurls,$urls,$url_ttl);
my ($doinaddr,$dns_timeout,@nameservers);

#
# USER CONFIGURABLE DEFAULTS:
#

$quiet			= 0;				# 0 == false; 1 == true;
$debug			= 0 - $quiet;			# 0 == false; 1 == true;
$verbose		= $debug || 0 - $quiet;		# 0 == false; 1 == true;

$doinaddr		= 0;				# 0 == false; 1 == true;
$dns_timeout		= 10;				# SECONDS BEFORE TIMEOUT DURING RESOLVING
@nameservers		= undef;			# undef||("ns1", "ns2", ...);

$umask			= 0027;				# usually 0002 || 0007

$home			= "/var/spool/www/hosts/proxy.ost.eltele.no/filter/robot";
$lib			= "$home/lib";
$etc			= "$home/etc";

$source_proxy		= "http://proxy:80/";		# undef||"http://proxy:1234/"
$link_proxy		= undef;			# undef||$source_proxy

$simultaneous_sources	= 16;				# NUMBER OF SIMULTANEOUS SOURCE REQUESTS
$simultaneous_links	= 32;				# NUMBER OF SIMULTANEOUS LINK REQUESTS
$bulk			= 512;				# MAX NUMBER OF REQUESTS IN A BULK

$fake_user_agent	= "Mozilla/4.72 [en] (WinNT; U)";# undef||"Mozilla/4.72 [en] (WinNT; U)"

$sources		= "$etc/source";		# ADD NEW SOURCES HERE; SLURPED AT STARTUP
$source_timeout		= 300;				# SECONDS BEFORE TIMEOUT DURING "GET"
$source_retries		= 4;				# NO OF FAILURES BEFORE MARKED AS BOUNCING
$source_bouncing_ttl	= 30;				# DAYS BEFORE TESTING A SOURCE MARKED AS BOUNCING
$source_remember	= 180;				# DAYS BEFORE REMOVING A SOURCE MARKED AS BOUNCING
$source_min_ttl		= 2;				# MIN DAYS A SOURCE SHOULD BE LISTED AS SUCCEEDING
$source_max_ttl		= 10;				# MAX DAYS A SOURCE SHOULD BE LISTED AS SUCCEEDING
$candidates		= "$etc/candidate";		# SOURCE REDIRECTS ARE LOGGED HERE

$links			= "$etc/link";			# ADD NEW URLS HERE; SLURPED AT STARTUP
$link_timeout		= 20;				# SECONDS BEFORE TIMEOUT DURING HEAD
$link_retries		= 3;				# FAILURES BEFORE MOVED TO THE BOUNCING LIST
$link_bouncing_ttl	= 30;				# DAYS BEFORE TESTING A LINK MARKED AS BOUNCING
$link_remember		= 90;				# DAYS BEFORE REMOVING A LINK MARKED AS BOUNCING
$link_min_ttl		= 15;				# MIN DAYS A LINK SHOULD BE LISTED AS SUCCEEDING
$link_max_ttl		= 30;				# MAX DAYS A LINK SHOULD BE LISTED AS SUCCEEDING

$domainexceptions	= "$etc/domainexception";	# ADD NEW DOMAIN EXCEPTIONS HERE; SLURPED AT STARTUP
$urlexceptions		= "$etc/urlexception";		# ADD NEW URL EXCEPTIONS HERE; SLURPED AT STARTUP
$exceptions		= "$etc/exception";		# ADD NEW EXCEPTIONS HERE; SLURPED AT STARTUP
$includes		= "$etc/include";		# ADD NEW INCLUDES HERE; SLURPED AT STARTUP
$redirectors		= "$etc/redirector";		# ADD NEW REDIRECTORS HERE; SLURPED AT STARTUP

$patterns		= "$etc/patterns";		# file || undef	# LIST OF BAD STRINGS AND PERLRE(3)
							# DOMAIN MATCH FORCES A DOMAIN LIST ENTRY

$domains		= "$etc/domain";		# CREATED AND MAINTAINED BY THIS PROGRAM
$domain_ttl		= 30;				# DAYS TO KEEP A DOMAIN
$urls			= "$etc/url";			# CREATED AND MAINTAINED BY THIS PROGRAM
$url_ttl		= 30;				# DAYS TO KEEP AN URL

$domainlist		= "$etc/domains";		# THE DOMAIN LIST CREATED BY THIS PROGRAM
$urllist		= "$etc/urls";			# THE URL LIST CREATED BY THIS PROGRAM
$newdomains		= "$etc/newdomains";		# THE DOMAIN NEWS THIS TIME; CREATED BY THIS PROGRAM
$newurls		= "$etc/newurls";		# THE URL NEWS THIS TIME; CREATED BY THIS PROGRAM

#
# END USER CONFIGURABLE DEFAULTS
#

unshift(@INC, "$lib");
use strict;
use Config;
use Getopt::Std;
use POSIX qw(strftime);
use DB_File;
use Net::DNS;
use IO::Select;
use HTTP::Request;
use HTTP::Response;
use HTTP::Status;
use HTML::LinkExtor;
require RobotUserAgent;

my $progname = $0; $progname =~ s/.*\057//;
my (%source,$sourcedb);
my (%candidate, $candidatedb);
my (%link,$linkdb);
my (%domain,$domaindb);
my (%url,$urldb);
my (%domainexception,$domainexceptiondb);
my (%urlexception,$urlexceptiondb);
my (%exception,$exceptiondb);
my (%include,$includedb);
my (%redirector,$redirectordb);
my (@patterns);
my ($start, $now, $checkpoint, $delta, $from, %signal) = time;
my %keys = (
	    found => 1,
	    id => 1,
	    last => 1,
	    referer => 1,
	    remote => 1,
	    retries => 1,
	    status => 1,
	    ttl => 1,
	    used => 1,
	   );

sub init();
sub load();
sub usage($);
sub date($);
sub strtime($);
sub msg($@);
sub status($@);
sub info($@);
sub debug($@);
sub warning($@);
sub error($@);
sub mirror($);
sub domaincmp($$);
sub linkmatch($$);
sub domainmatch($$);
sub urlmatch($$);
sub exceptionmatch($$);
sub addnew($$);
sub patterns($);
sub expire();
sub expiredomains();
sub expireurls();
sub washlinks();
sub release($);
sub min($$);
sub addlink($$);
sub addcandidate($$);
sub dumpcandidates();
sub extract();
sub success($);
sub redirect($);
sub spliturl($);
sub domain($);
sub check();
sub adddomain($$);
sub addurl($$$);
sub addresses($$);
sub washdomains();
sub washurls();
sub wash();
sub compile($);
sub today();
sub export();
sub valid($);
sub dumpkeys($$$);
sub end($);

sub init() {
  my (%opts, $i);
  getopts("hc:dqQvV", \%opts) || usage(1);
  if (defined($opts{h})) {
    usage(0);
  }
  if (defined($opts{c})) {
    open(CONFIG, $opts{c}) || error("$opts{c}: $!");
    while(<CONFIG>) {
      eval;
    }
    close(CONFIG);
  }
  if (defined($opts{"d"})) {
    $debug = 1;
    $verbose = 1;
    $quiet = 0;
  }
  if (defined($opts{"q"})) {
    $debug = 0;
    $verbose = 0;
  }
  if (defined($opts{"Q"})) {
    $debug = 0;
    $verbose = 0;
    $quiet = 1;
  }
  if (defined($opts{"v"})) {
    $verbose = 1;
    $quiet = 0;
  }
  if (defined($opts{"V"})) {
    print "$VERSION\n";
    exit(0);
  }
  status("Started");
  
  umask $umask;
  select(STDERR);$|=1;
  select(STDOUT);$|=1;

  $i = 0;
  foreach(split(' ', $Config{sig_name})) {
    $signal{$_} = $i++;
  }
  
  $DB_BTREE->{compare} = \&linkmatch;
  $sourcedb = tie(%source,"DB_File","$sources.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$sources.db: $!");
  
  $DB_BTREE->{compare} = \&linkmatch;
  $candidatedb = tie(%candidate,"DB_File","$candidates.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$candidates.db: $!");
  
  $DB_BTREE->{compare} = \&linkmatch;
  $linkdb = tie(%link,"DB_File","$links.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$links.db: $!");
  
  $DB_BTREE->{compare} = \&domainmatch;
  $domaindb = tie(%domain,"DB_File","$domains.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$domains.db: $!");
  
  $DB_BTREE->{compare} = \&urlmatch;
  $urldb = tie(%url,"DB_File","$urls.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$urls.db: $!");
  
  $DB_BTREE->{compare} = \&domainmatch;
  $domainexceptiondb = tie(%domainexception,"DB_File","$domainexceptions.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$domainexceptions.db: $!");
  
  $DB_BTREE->{compare} = \&urlmatch;
  $urlexceptiondb = tie(%urlexception,"DB_File","$urlexceptions.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$urlexceptions.db: $!");
  
  $DB_BTREE->{compare} = \&exceptionmatch;
  $exceptiondb = tie(%exception,"DB_File","$exceptions.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$exceptions.db: $!");
  
  $DB_BTREE->{compare} = \&urlmatch;
  $includedb = tie(%include,"DB_File","$includes.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$includes.db: $!");
  
  $DB_BTREE->{compare} = \&domainmatch;
  $redirectordb = tie(%redirector,"DB_File","$redirectors.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$redirectors.db: $!");
  
  $SIG{INT} = \&end;
  $SIG{TERM} = \&end;

  $now = $checkpoint = time;
  status("Initialized in %s", strtime($now-$start));
}

sub load() {
  my (@new,$wash,$key,$k,$v,$n);
  my $new = 0;
  $new += scalar(addnew(\%source, $sources));
  $sourcedb->sync();
  $new += scalar(addnew(\%link, $links));
  $linkdb->sync();
  $new += scalar(addnew(\%domain, $domains));
  $domaindb->sync();
  $new += scalar(addnew(\%url, $urls));
  $urldb->sync();
  $new += scalar(addnew(\%include, $includes));
  $includedb->sync();
  if (@new) {
    $new += scalar(@new);
    $wash++;
    foreach $key (@new) {
      $k = $key;
      $v = 0;
      for ($n = $includedb->seq($k,$v,R_CURSOR);
	   $n == 0 && urlmatch($k,$key) == 0;
	   $k = $key, $n = $includedb->seq($k,$v,R_CURSOR)) {
	my %data = split(/[=;]/, $include{$k});
	info("Removing obsoleted include: %s", $k);
	$includedb->del_dup($k,$v);
	$includedb->sync();
      }
    }
  }
  @new = addnew(\%domainexception, $domainexceptions);
  $domainexceptiondb->sync();
  if (@new) {
    $new += scalar(@new);
    $wash++;
    foreach $key (@new) {
      $k = $key;
      $v = 0;
      for ($n = $urldb->seq($k,$v,R_CURSOR);
	   $n == 0 && urlmatch($k,$key) == 0;
	   $k = $key, $n = $urldb->seq($k,$v,R_CURSOR)) {
	unless(exists($include{$k})) {
	  my %data = split(/[=;]/, $v);
	  info("Removing obsoleted url (domainexception=%s): %s",$key,$k);
	  release($data{referer});
	  $urldb->del_dup($k,$v);
	  $urldb->sync();
	}
      }
      $k = $key;
      $v = 0;
      for ($n = $domaindb->seq($k,$v,R_CURSOR);
	   $n == 0 && domainmatch($k,$key) == 0;
	   $k = $key, $n = $domaindb->seq($k,$v,R_CURSOR)) {
	my %data = split(/[=;]/, $v);
	info("Removing obsoleted domain (domainexception=%s): %s",$key,$k);
	release($data{referer});
	$domaindb->del_dup($k,$v);
	$domaindb->sync();
      }
    }
  }
  @new = addnew(\%urlexception, $urlexceptions);
  $urlexceptiondb->sync();
  if (@new) {
    $new += scalar(@new);
    $wash++;
    foreach $key (@new) {
      $k = $key;
      $v = 0;
      for ($n = $urldb->seq($k,$v,R_CURSOR);
	   $n == 0 && urlmatch($k,$key) == 0;
	   $k = $key, $n = $urldb->seq($k,$v,R_CURSOR)) {
	my %data = split(/[=;]/, $v);
	info("Removing obsoleted url (urlexception=%s): %s",$key,$k);
	release($data{referer});
	$urldb->del_dup($k,$v);
	$urldb->sync();
      }
    }
  }
  @new = addnew(\%exception, $exceptions);
  $exceptiondb->sync();
  if (@new) {
    $new += scalar(@new);
    $wash++;
    foreach $key (@new) {
      while(exists($url{$key})) {
	my %data = split(/[=;]/, $url{$key});
	info("Removing obsoleted url (exception): %s", $key);
	release($data{referer});
	$k = $key;
	$v = $url{$key};
	$urldb->del_dup($k,$v);
	$urldb->sync();
      }
      while(exists($domain{$key})) {
	my %data = split(/[=;]/, $domain{$key});
	info("Removing obsoleted domain (exception): %s", $key);
	release($data{referer});
	$k = $key;
	$v = $domain{$key};
	$domaindb->del_dup($k,$v);
	$domaindb->sync();
      }
    }
  }
  $new += scalar(addnew(\%redirector, $redirectors));
  $redirectordb->sync();
  $now = time;
  status("Loaded %d new entries in %s",$new,strtime($now-$checkpoint));
  $checkpoint = $now;
  @patterns = patterns($patterns);
  washlinks() if($wash);
}

sub usage($) {
  my $exit = shift;
  print STDERR "\n$progname $VERSION\n\n";
  print STDERR "Usage: $progname \133options\135\n";
  print STDERR "Where the options are:\n";
  print STDERR "\t-h\t\t\t\043 help\n";
  print STDERR "\t-q|-v\t\t\t\043 quiet or verbose\n";
  print STDERR "\t-c <config_file>\t\043 File with Perl code to override the defaults\n";
  print STDERR "\n";
  exit($exit);
}

sub date($) {
  my $time = shift;
  strftime("%Y.%m.%d %T", localtime($time));
}

sub strtime($) {
  my $time = shift;
  sprintf("%d:%02d:%02d", $time/3600, $time/60%60, $time%60);
}

sub msg($@) {
  my $format = shift;
  printf STDOUT "%s $progname: $format\n", date(time), @_;
}

sub status($@) {
  return if($quiet);
  my $format = shift;
  $format = "STATUS: $format" unless($format =~ /^status:/i);
  msg($format, @_);
}

sub info($@) {
  return unless($verbose);
  my $format = shift;
  $format = "INFO: $format" unless($format =~ /^info:/i);
  msg($format, @_);
}
	  
sub debug($@) {
  return unless($debug);
  my $format = shift;
  $format = "DEBUG: $format" unless($format =~ /^debug:/i);
  msg($format, @_);
}

sub warning($@) {
  my $format = shift;
  $format = "WARNING: $format" unless($format =~ /^(error|warning):/i);
  printf STDERR "%s $progname: $format\n", date(time), @_;
}

sub error($@) {
  my $format = shift;
  $format = "ERROR: $format" unless($format =~ /^(error|warning):/i);
  warning($format, @_);
  end(-1);
}

sub mirror($) {
  scalar(reverse(shift));
}

sub domaincmp($$) {
  my $search = mirror(lc(shift));
  my $found = mirror(lc(shift));
  return($search . "." cmp $found . ".");
}

sub linkmatch($$) {
  my $search = shift;
  my $found = shift;
  #debug("linkmatch(%s,%s)", $search, $found);
  $search = lc($search);
  $found = lc($found);
  $search =~ s@/index\.s?html?$@@;
  $found =~ s@/index\.s?html?$@@;
  if ($search eq $found
      || $search . "/" eq $found
      || $search eq $found . "/") {
    return(0);
  } else {
    return($search cmp $found);
  }
}

sub domainmatch($$) {
  my $search = shift;
  my $found = shift;
  #debug("domainmatch(%s,%s)", $search, $found);
  $search = mirror(lc($search));
  $found = mirror(lc($found));
  if ($search eq $found) {
    return(0);
  } else {
    $found .= ".";
    $search = substr($search,0,length($found));
    #debug("domainmatch(%s,%s)", mirror($search), mirror($found));
    return($search cmp $found);
  }
}

sub urlmatch($$) {
  my $search = shift;
  my $found = shift;
  #debug("urlmatch(%s,%s)", $search, $found);
  $search = lc($search) . "/";
  $found = lc($found) . "/";
  if ($search eq $found) {
    return(0);
  } else {
    $search = substr($search,0,length($found));
    return($search cmp $found);
  }
}

sub exceptionmatch($$) {
  my $search = shift;
  my $found = shift;
  #debug("exceptionmatch(%s,%s)", $search, $found);
  $search = lc($search);
  $found = lc($found);
  if ($search eq $found) {
    return(0);
  } else {
    $search =~ s@/([^/]+\.(s?html?|cgi|php\d?|asp))?$@@;
    return($search cmp $found);
  }
}

sub addnew($$) {
  my ($db, $file) = @_;
  my @new;
  if (-f $file) {
    my ($added, $ignored, $key, $val) = (0, 0);
    status("Adding new entries from $file..");
    open(FILE, $file) || error("$file: $!");
    while(<FILE>) {
      chomp;
      s/\043.*//;
      next unless($_);
      ($key, $val) = split(/\s+/, $_);
      if (exists($db->{$key})) {
	$ignored++;
	debug("Ignored (seen before): %s", $key);
      } else {
	$added++;
	push(@new,$key);
	$val = "" unless($val);
	$db->{$key} = $val;
	info("Added: %s", $key);
      }
    }
    close(FILE);
    status("Added $added and ignored $ignored entries from $file.");
  } else {
    warning("$file: $!");
  }
  return(@new)
}

sub patterns($) {
  my $file = shift;
  my @patterns;
  if (-f $file) {
    my $added = 0;
    status("Loading patterns from $file..");
    open(FILE, $file) || error("$file: $!");
    while(<FILE>) {
      chomp;
      s/\043.*//;
      next unless($_);
      push(@patterns, $_);
    }
    close(FILE);
    status("Loaded %d patterns from $file.", scalar(@patterns));
  } else {
    warning("$file: $!");
  }
  return(@patterns)
}

sub release($) {
  my $key = shift || return;
  my %data = split(/[=;]/, $link{$key} || "");
  my ($val,$k,$v);
  $val="";
  $data{used} = 0;
  while(($k,$v) = each(%data)) {
    next unless($k && $keys{$k});
    $v =~ s/=/%3D/g;
    $v =~ s/;/%3B/g;
    $val.="$k=$v;"
  }
  $linkdb->put($key, $val);
  $linkdb->sync();
}

sub expiredomains() {
  my ($key,$val,$status,%expired,%obsolete,%redundant);
  status("Checking the domain list for expired and redundant entries..");
  undef($domaindb);
  untie(%domain);
  $DB_BTREE->{compare} = \&domaincmp;
  $domaindb = tie(%domain,"DB_File","$domains.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$domains.db: $!");
  $key = $val = 0;
  for ($status = $domaindb->seq($key, $val, R_FIRST);
       $status == 0;
       $status = $domaindb->seq($key, $val, R_NEXT)) {
    my %data = split(/[=;]/, $val || "");
    if (!(exists($data{last}) && exists($data{ttl}) && exists($data{referer}))) {
      info("Removing expired domain: %s: %s", $key, $val || "undef");
      $expired{$key} = $val;
    } elsif ($data{last} + $data{ttl} < $now) {
      info("Removing expired domain: %s: %s", $key, $val);
      release($data{referer});
      $expired{$key} = $val;
    } elsif (exists($domainexception{$key}) && !exists($include{$key})) {
      info("Removing obsolete domain (domainexception): %s", $key);
      release($data{referer});
      $obsolete{$key} = $val;
    } elsif (exists($exception{$key}) && !exists($include{$key})) {
      info("Removing obsolete domain (exception): %s", $key);
      release($data{referer});
      $obsolete{$key} = $val;
    } else {
      my ($host,$domain) = split(/\./, $key, 2);
      if($domain && exists($domain{$domain})) {
	info("Removing redundant domain: %s", $key);
	release($data{referer});
	$redundant{$key} = $val;
      }
    }
  }
  while(($key,$val) = each(%expired)) {
    $domaindb->del_dup($key,$val);
    $domaindb->sync();
  }
  while(($key,$val) = each(%obsolete)) {
    $domaindb->del_dup($key,$val);
    $domaindb->sync();
  }
  while(($key,$val) = each(%redundant)) {
    $domaindb->del_dup($key,$val);
    $domaindb->sync();
  }
  $DB_BTREE->{compare} = \&domainmatch;
  $domaindb = tie(%domain,"DB_File","$domains.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$domains.db: $!");
  $now = time;
  status("Removed %d expired, %d obsolete and %d redundant of %d domains in %s",
         scalar(keys(%expired)), scalar(keys(%obsolete)), scalar(keys(%redundant)),
	 scalar(keys(%domain)), strtime($now-$checkpoint));
  $checkpoint = $now;
}

sub expireurls() {
  my ($key,$val,%expired,%obsolete,%redundant);
  status("Checking the url list for expired and redundant entries..");
  while(($key,$val) = each(%url)) {
    my %data = split(/[=;]/, $val || "");
    if ($data{last} + $data{ttl} < $now) {
      info("Removing expired url: %s: %s", $key, $val);
      release($data{referer});
      $expired{$key} = $val;
    } elsif (exists($domainexception{$key}) && !exists($include{$key})) {
      info("Removing obsolete url (domainexception): %s", $key);
      release($data{referer});
      $obsolete{$key} = $val;
    } elsif (exists($urlexception{$key}) && !exists($include{$key})) {
      info("Removing obsolete url (urlexception): %s", $key);
      release($data{referer});
      $obsolete{$key} = $val;
    } elsif (exists($exception{$key}) && !exists($include{$key})) {
      info("Removing obsolete url (exception): %s", $key);
      release($data{referer});
      $obsolete{$key} = $val;
    } else {
      my $domain = $key;
      $domain =~ s@/.*@@;
      if(exists($domain{$domain})) {
	my %d = split(/[=;]/, $domain{$domain});
	info("Removing redundant url: %s", $key);
	release($data{referer}) unless(lc($data{referer}) eq lc($d{referer}));
	$redundant{$key} = $val;
      } else {
	my $k = $key;
	$k =~ s@/[^/]+/?$@@;
	if(exists($url{$k})) {
	  my %u = split(/[=;]/, $url{$k});
	  info("Removing redundant url: %s", $key);
	  release($data{referer}) unless(lc($data{referer}) eq lc($u{referer}));
	  $redundant{$key} = $val;
	}
      }
    }
  }
  while(($key,$val) = each(%expired)) {
    $urldb->del_dup($key,$val);
    $urldb->sync();
  }
  while(($key,$val) = each(%obsolete)) {
    $urldb->del_dup($key,$val);
    $urldb->sync();
  }
  while(($key,$val) = each(%redundant)) {
    $urldb->del_dup($key,$val);
    $urldb->sync();
  }
  $now = time;
  status("Removed %d expired, %d obsolete and %d redundant of %d urls in %s",
         scalar(keys(%expired)), scalar(keys(%obsolete)), scalar(keys(%redundant)),
	 scalar(keys(%url)), strtime($now-$checkpoint));
  $checkpoint = $now;
}

sub expire() {
  expiredomains();
  expireurls();
}

sub washlinks() {
  my ($key,$val,$removed);
  status("Washing the link list..");
  $removed = 0;
  while(($key,$val) = each(%link)) {
    my ($domain,$path,$url) = spliturl($key);
    unless($domain) {
      info("Removing (bad format): %s", $key);
      $linkdb->del($key);
      $linkdb->sync();
      $removed++;
      next;
    }
    unless(exists($include{$url})) {
      if(exists($domainexception{$domain})) {
	info("Removing (domainexception): %s", $key);
	$linkdb->del($key);
	$linkdb->sync();
	$removed++;
	next;
      }
      if(exists($urlexception{$url})) {
	info("Removing (urlexception): %s", $key);
	$linkdb->del($key);
	$linkdb->sync();
	$removed++;
	next;
      }
      if(exists($exception{$url})) {
	info("Removing (exception): %s", $key);
	$linkdb->del($key);
	$linkdb->sync();
	$removed++;
	next;
      }
    }
  }
  $linkdb->sync();
  $now = time;
  status("Removed %d of %d links in %s",$removed, scalar(keys(%link)), strtime($now-$checkpoint));
  $checkpoint = $now;
}

sub addlink($$) {
  my ($link, $referer) = @_;
  my ($domain,$path,$url) = spliturl($link);
  my $found = $checkpoint;
  return(0) unless($domain);
  $link =~ s/\043.*//;
  $link =~ s/(\s)/sprintf("%%%02x",ord($1))/eg;
  $link =~ s/^(https?|ftp):\057\057([^\100\057]*\100)/$1:\057\057/;
  if(exists($link{$link}) && $link{$link}) {
    debug("Ignored (seen before): %s", $link);
    return(0);
  }
  if (exists($source{$link})) {
    my %data = split(/[=;]/, $source{$link});
    $found = $data{found} || $checkpoint;
  } else {
    unless(exists($include{$url})) {
      if(exists($domainexception{$domain})) {
	debug("Ignored (domainexception): %s", $link);
	return(0);
      }
      if(exists($urlexception{$url})) {
	debug("Ignored (urlexception): %s", $link);
	return(0);
      }
      if(exists($exception{$url})) {
	debug("Ignored (exception): %s", $link);
	return(0);
      }
    }
  }
  info("Adding new link: %s (referer=%s)", $link, $referer);
  $referer =~ s/=/%3D/g;
  $referer =~ s/;/%3B/g;
  $link =~ s@>.*@@;
  $link =~ s@/(index|welcome|default).(s?html?|cgi)@@i;
  $linkdb->put($link, "last=0;ttl=0;status=0;found=$found;used=-1;referer=$referer;");
  $linkdb->sync();
  return(1);
}

sub min($$) {
  my ($a,$b) = @_;
  if($a < $b) {
    return($a);
  } else {
    return($b);
  }
}

sub addcandidate($$) {
  my ($candidate, $referer) = @_;
  my ($domain,$path,$url) = spliturl($candidate);
  return(0) unless($domain);
  if(exists($candidate{$candidate}) && $candidate{$candidate}) {
    debug("Ignored (seen before): %s", $candidate);
    return(0);
  }
  unless(exists($include{$url})) {
    if(exists($domainexception{$domain})) {
      debug("Ignored (domainexception): %s", $candidate);
      return(0);
    }
    if(exists($urlexception{$url})) {
      debug("Ignored (urlexception): %s", $candidate);
      return(0);
    }
    if(exists($exception{$url})) {
      debug("Ignored (exception): %s", $candidate);
      return(0);
    }
  }
  info("Adding new candidate: %s (referer=%s)", $candidate, $referer);
  $referer =~ s/=/%3D/g;
  $referer =~ s/;/%3B/g;
  $candidatedb->put($candidate, "found=$checkpoint;referer=$referer;");
  $candidatedb->sync();
  return(1);
}

sub dumpcandidates() {
  my ($key,$val);
  open(CANDIDATE, ">$candidates") || error("$candidates: $!");
  while(($key,$val) = each(%candidate)) {
    print CANDIDATE "$key\t$val\n";
  }
  close(CANDIDATE);
}

sub extract() {
  my @requests;
  status("Checking the status of the sources..");
  if (scalar(keys(%source))) {
    my ($key,$val,$k,$v,%data,$request);
    my $retry = time-($source_bouncing_ttl*86400);
    my ($new,$succeeded,$failed,$downloads,$rest) = (0,0,0,0,0);
    while(($key,$val) = each(%source)) {
      %data = split(/[=;]/, $val || "");
      if(!exists($data{found}) || !exists($data{last})
	 || !exists($data{ttl}) || !exists($data{retries})) {
	$data{found} = $start unless(exists($data{found}));
	$data{last} = 0 unless(exists($data{last}));
	$data{ttl} = 0 unless(exists($data{ttl}));
	$data{retries} = $source_retries unless(exists($data{retries}));
	$val="";
	while(($k,$v) = each(%data)) {
	  next unless($k && $keys{$k});
	  $v =~ s/=/%3D/g;
	  $v =~ s/;/%3B/g;
	  $val.="$k=$v;"
	}
	$sourcedb->put($key, $val);
	$sourcedb->sync();
      }
      if(($data{last}>=0 && $data{last}+$data{ttl}<$now)
	 || ($data{last}<0 && -$data{last}+$data{ttl}<$retry)) {
	debug("Prepairing: %s", $key);
	push(@requests, HTTP::Request->new(GET => $key));
      }
    }
    $sourcedb->sync();
    $now = time;
    status("Checked %d sources in %s",
	   scalar(keys(%source)),
	   strtime($now-$checkpoint));
    $checkpoint = $delta = $now;
    $downloads = $rest = scalar(@requests);
    while(@requests) {
      my ($ua,$response,$domain,$extor,%extorelements,$tag,%links,$link,$found,$n);
      $now = time;
      status("Downloading bulk of %d of %d sources..",
	   min(scalar(@requests),$bulk), $downloads);
      $checkpoint = $now;
      $ua = RobotUserAgent->new();
      $ua->proxy(['http', 'ftp'], $source_proxy) if($source_proxy);
      $ua->agent($fake_user_agent) if($fake_user_agent);
      $ua->timeout($source_timeout) if($source_timeout);
      $ua->redirect(0);
      $ua->in_order(0);
      $ua->remember_failures(1);
      $ua->max_hosts($simultaneous_sources||1);
      $ua->max_req(4);
      while(@requests) {
	last if($n++ >= $bulk);
	my $request = shift(@requests);
	$rest--;
	warning($response->status_line) if($response = $ua->register($request));
      }
      $SIG{PIPE} = "IGNORE";
      $response = $ua->wait();
      $SIG{PIPE} = "DEFAULT";
      $now = time;
      $found = 0;
      status("Downloaded %d of %d sources in %s",
	     scalar(keys(%$response)),
	     $downloads,
	     strtime($now-$checkpoint)
	    );
      status("Parsing %d sources..", scalar(keys(%$response)));
      %extorelements = %HTML::LinkExtor::LINK_ELEMENT;
      %HTML::LinkExtor::LINK_ELEMENT = (a => "href",
					#img => "src",
					form => "action",
					base => "href");
      foreach (keys(%$response)) {
	$key = $response->{$_}->{request}->{_uri};
	%data = split(/[=;]/, $source{$key});
	debug("Checking %s: %s", $key, $response->{$_}->response->status_line);
	$data{status} = $response->{$_}->response->code;
	if ($response->{$_}->response->is_success) {
	  $succeeded++;
	  $data{last} = $checkpoint;
	  $data{ttl} = int(rand($source_max_ttl - $source_min_ttl + 1))*86400;
	  $data{retries} = $source_retries;
	  $extor = HTML::LinkExtor->new(undef, $response->{$_}->response->base);
	  $extor->parse($response->{$_}->response->content);
	  addlink($key, $key);
	  foreach ($extor->links) {
	    ($tag, %links) = @$_;
	    foreach (keys(%links)) {
	      $link = $links{$_};
	      ($domain) = spliturl($link);
	      unless($domain && exists($redirector{$domain})) {
		$found++ if(addlink($link, $key));
	      }
	    }
	  }
	} else {
	  $failed++;
	  if($data{retries}-- <= 0) {
	    $data{retries} = $source_retries;
	    if ($data{last} < 0) {
	      $data{ttl} += int(rand($source_max_ttl - $source_min_ttl + 1))*86400;
	    } else {
	      $data{last} = -$checkpoint ;
	      $data{ttl} = int(rand($source_max_ttl - $source_min_ttl + 1))*86400;
	    }
	  }
	  if (redirect($response->{$_}->response->code)) {
	    addcandidate($response->{$_}->response->header("Location"), $key);
	  }
        }
	if ($data{ttl} > $source_remember*86400 && $data{last} < 0) {
	  info("Removing bouncing source: %s (last=%d,ttl=%d,retries=%d,status=%s)",
	       $key,$data{last},$data{ttl},$data{retries},$data{status});
          $sourcedb->del($key);
	  $sourcedb->sync();
	} else {
	  $val="";
	  while(($k,$v) = each(%data)) {
	    next unless($k && $keys{$k});
	    $v =~ s/=/%3D/g;
	    $v =~ s/;/%3B/g;
	    $val.="$k=$v;"
	  }
	  $sourcedb->put($key, $val);
	  $sourcedb->sync();
	}
      }
      $sourcedb->sync();
      $linkdb->sync();
      %HTML::LinkExtor::LINK_ELEMENT = %extorelements;
      $checkpoint = $now;
      $now = time;
      status("Added %d new links from bulk of %d sources in %s",
	     $found, $n, strtime($now-$checkpoint));
      $new += $found;
      status("Still %d of %d sources to go..", $rest, $downloads) if($rest);
    }
    $checkpoint = $now;
    $now = time;
    status("Added %d new links from %d sources", $new, $downloads);
    status("Downloaded and parsed %d of %d source in %s, %d succeeded and %d failed",
	   $downloads, scalar(keys(%source)), strtime($now-$delta),
	   $succeeded, $failed);
  }
}

sub success($) {
  my $code = shift;
  return(1) if ($code >= 200 && $code < 300);
  return(1) if ($code == RC_UNAUTHORIZED);
  return(1) if ($code == RC_PAYMENT_REQUIRED);
  return(1) if ($code == RC_FORBIDDEN);
  return(0);
}

sub redirect($) {
  my $code = shift;
  return(1) if ($code == RC_MOVED_PERMANENTLY);
  return(1) if ($code == RC_FOUND);
  return(0);
}

sub spliturl($) {
  my $link = lc(shift);
  my ($proto, $host, $domain, $path, $url);
  $link =~ /^(https?|ftp):\057\057([^\100\057]*\100)?((www|web|ftp)\d{0,2}\.)?([-.a-z0-9]+)\.?(:\d*)?([^\043]*)/i;
  $proto = $1 || return(undef,undef,undef,undef);
  $domain = $5 || return(undef,undef,undef,undef);
  $host = $3 || "" . $domain;
  $path = $7 || "";
  $path =~ s@\?.*@@ unless(exists($redirector{$domain}));
  $path =~ s@>.*@@;
  $path =~ s@/[^/]+\.(s?html?|cgi|php\d?|asp|jpe?g|gif|ra?m|mpe?g?|mov|movie|qt|avi|dif|dvd?|mpv2|mp3)$@@;
  $path =~ s@/+$@@;
  $path =~ s@//+@/@g;
  $path =~ s@/pub/?$@/@;
  $path =~ s/(\s)/sprintf("%%%02x",ord($1))/eg;
  $path =~ s/%([a-f\d]{2})/if(hex($1)==9||hex($1)==10||hex($1)==13||hex($1)==32){"%$1"}else{chr(hex($1))}/egi;
  $url = $domain . $path;
  return(($domain, $path, $url, $host));
}

sub domain($) {
  my $link = shift;
  my ($domain, $path, $url);
  $link =~ /^(https?|ftp):\057\057([^\100\057]*\100)?((www|web|ftp)\d{0,2}\.)?([-.a-z0-9]+)\.?(:\d*)?([^\043]*)/i;
  return($5 || "");
}

sub check() {
  my @requests;
  status("Checking the status of the links..");
  if (scalar(keys(%link))) {
    my ($key,$val,$k,$v,%data,$request);
    my $retry = time-($link_bouncing_ttl*86400);
    my ($new,$succeeded,$failed,$tests,$rest) = (0,0,0,0,0);
    while(($key,$val) = each(%link)) {
      next if($key =~ /^https:/); # Parallel::UserAgent can not handle 'https'-requests.
      %data = split(/[=;]/, $val);
      if(!exists($data{last}) || !exists($data{ttl})
	 || !exists($data{retries}) || !exists($data{used})) {
	$data{last} = 0 unless(exists($data{last}));
	$data{ttl} = 0 unless(exists($data{ttl}));
	$data{retries} = $link_retries unless(exists($data{retries}));
	$data{used} = -1 unless(exists($data{used}));
	$val="";
	while(($k,$v) = each(%data)) {
	  next unless($k && $keys{$k});
	  $v =~ s/=/%3D/g;
	  $v =~ s/;/%3B/g;
	  $val.="$k=$v;"
	}
	$linkdb->put($key, $val);
	$linkdb->sync();
      }
      if ($data{used}) {
	if(($data{last}>=0 && $data{last}+$data{ttl}<$now)
	   || ($data{last}<0 && -$data{last}+$data{ttl}<$retry)) {
	  debug("Prepairing: %s", $key);
	  push(@requests, HTTP::Request->new(HEAD => $key));
	}
      }
    }
    $linkdb->sync();
    $now = time;
    status("Checked %d links in %s",
	   scalar(keys(%link)),
	   strtime($now-$checkpoint));
    $checkpoint = $delta = $now;
    $tests = $rest = scalar(@requests);
    while(@requests) {
      my ($ua,$response,$link,$found,$n);
      $now = time;
      status("Verifying bulk of %d of %d links..",
	   min(scalar(@requests),$bulk), $tests);
      $checkpoint = $now;
      $ua = RobotUserAgent->new();
      $ua->proxy(['http', 'ftp'], $link_proxy) if($link_proxy);
      $ua->agent($fake_user_agent) if($fake_user_agent);
      $ua->timeout($link_timeout) if($link_timeout);
      $ua->redirect(0);
      $ua->in_order(0);
      $ua->remember_failures(1);
      $ua->max_hosts($simultaneous_links||1);
      $ua->max_req(4);
      while(@requests) {
	last if($n++ >= $bulk);
	my $request = shift(@requests);
	$rest--;
	warning($response->status_line) if($response = $ua->register($request));
      }
      $SIG{PIPE} = "IGNORE";
      $response = $ua->wait();
      $SIG{PIPE} = "DEFAULT";
      $now = time;
      $found = 0;
      status("Verified %d of %d links in %s",
	     scalar(keys(%$response)), $n, strtime($now-$checkpoint));
      status("Updating status for %d links..", scalar(keys(%$response)));
      foreach (keys(%$response)) {
	$key = $response->{$_}->{request}->{_uri};
	%data = split(/[=;]/, $link{$key} || "");
	debug("Checking %s: %s", $key, $response->{$_}->response->status_line);
	$data{status} = $response->{$_}->response->code;
        if (success($response->{$_}->response->code)) {
	  $succeeded++;
	  $data{last} = $checkpoint;
	  $data{ttl} = int(rand($link_max_ttl - $link_min_ttl + 1))*86400;
	  $data{retries} = $link_retries;
	} elsif (redirect($response->{$_}->response->code)) {
	  my ($domain,$path,$url) = spliturl($key);
	  if (exists($redirector{$domain})
	      || $path =~ /^\057cgi(-bin)?\057/
	      || $path =~ /\?/) {
	    my $location = $response->{$_}->response->header("Location");
	    $succeeded++;
	    $found += addlink($location, $key)
	      if($location && domain($location) ne $domain);
	    $data{last} = $checkpoint;
	    $data{ttl} = int(rand($link_max_ttl - $link_min_ttl + 1))*86400;
	    $data{retries} = $link_retries;
	  } else {
	    $failed++;
	    if($data{retries}-- <= 0) {
	      $data{retries} = $link_retries;
	      if ($data{last} < 0) {
		$data{ttl} += int(rand($link_max_ttl - $link_min_ttl + 1))*86400;
	      } else {
		$data{last} = -$checkpoint ;
		$data{ttl} = int(rand($link_max_ttl - $link_min_ttl + 1))*86400;
	      }
	    }
	  }
        } else {
	  if($data{retries}-- <= 0) {
	    $data{retries} = $link_retries;
	    if ($data{last} < 0) {
	      $data{ttl} += int(rand($link_max_ttl - $link_min_ttl + 1))*86400;
	    } else {
	      $data{last} = -$checkpoint ;
	      $data{ttl} = int(rand($link_max_ttl - $link_min_ttl + 1))*86400;
	    }
	  }
	}
	if ($data{ttl} > $link_remember*86400 && $data{last} < 0) {
	  info("Removing bouncing link: %s (last=%d,ttl=%d,retries=%d,status=%s)",
	       $key,$data{last},$data{ttl},$data{retries},$data{status});
          $linkdb->del($key);
	  $linkdb->sync();
	} else {
	  $val="";
	  while(($k,$v) = each(%data)) {
	    next unless($k && $keys{$k});
	    $v =~ s/=/%3D/g;
	    $v =~ s/;/%3B/g;
	    $val.="$k=$v;"
	  }
	  $linkdb->put($key, $val);
	  $linkdb->sync();
	}
      }
      $linkdb->sync();
      $checkpoint = $now;
      $now = time;
      status("Added %d new links from bulk of %d links in %s",
	     $found, $n, strtime($now-$checkpoint));
      $new += $found;
      status("Still %d of %d links to go..", $rest, $tests) if($rest);
    }
    $checkpoint = $now;
    status("Added %d new links from redirects",$new);
    status("Verified %d of %d links in %s, %d succeeded and %d failed",
	   $tests, scalar(keys(%link)), strtime($now-$delta),
	   $succeeded, $failed);
  }
}

sub adddomain($$) {
  my ($domain, $referer) = @_;
  my ($d,$val,$k,$v,$n);
  return(0) unless($domain && $referer && $domain =~ /\.\w+/);
  $d = $domain;
  $v = 0;
  if ($domaindb->seq($d,$v,R_CURSOR) == 0 && lc($domain) eq lc($d)) {
    my %data = split(/[=;]/, $v);
    $data{last} = $checkpoint;
    $data{ttl} = $domain_ttl*86400;
    $val="";
    while(($k,$v) = each(%data)) {
      next unless($k && $keys{$k});
      $v =~ s@=@%3D@g;
      $v =~ s@;@%3B@g;
      $val.="$k=$v;"
    }
    $domaindb->put($d, $val);
    $domaindb->sync();
    debug("Refreshed (seen before): %s", $domain);
    return(0);
  }
  if ($domaindb->seq($d,$v,R_CURSOR) == 0 && domainmatch($domain, $d) == 0) {
    debug("Ignored (redundant): %s", $domain);
    return(0);
  }
  if (exists($domainexception{$domain}) && !exists($include{$domain})) {
    debug("Ignored (domainexception): %s", $domain);
    return(0);
  }
  info("Adding new domain: %s (referer=%s)", $domain, $referer);
  my $id = int(rand(2147483647));
  $k = $domain;
  $v = 0;
  for ($n = $urldb->seq($k,$v,R_CURSOR);
       $n == 0 && urlmatch($k,$domain) == 0;
       $k = $domain, $n = $urldb->seq($k,$v,R_CURSOR)) {
    my %data = split(/[=;]/, $v || "");
    info("Removing redundant url: %s", $k);
    $urldb->del_dup($k,$v);
    $domaindb->sync();
    release($data{referer}) unless(lc($data{referer}) eq lc($referer));
  }
  for ($n = $domaindb->seq($k,$v,R_CURSOR);
       $n == 0 && domainmatch($k,$domain) == 0;
       $k = $domain, $n = $domaindb->seq($k,$v,R_CURSOR)) {
    my %data = split(/[=;]/, $v || "");
    info("Removing redundant domain: %s", $k);
    $domaindb->del_dup($k,$v);
    $domaindb->sync();
    release($data{referer}) unless(lc($data{referer}) eq lc($referer));
  }
  $referer =~ s/=/%3D/g;
  $referer =~ s/;/%3B/g;
  $v = $domain_ttl*86400;
  $domaindb->put($domain, "last=$checkpoint;ttl=$v;found=$checkpoint;referer=$referer;id=$id;");
  $domaindb->sync();
  return(1);
}

sub addurl($$$) {
  my ($domain, $url, $referer) = @_;
  my ($d,$u,$val,$k,$v,$n);
  return(0) unless($url && $referer && $url =~ /\.\w+/);
  $d = $domain;
  $v = 0;
  if ($domaindb->seq($d,$v,R_CURSOR) == 0 && lc($domain) eq lc($d)) {
    my %data = split(/[=;]/, $v);
    $data{last} = $checkpoint;
    $data{ttl} = $domain_ttl*86400;
    $val="";
    while(($k,$v) = each(%data)) {
      next unless($k && $keys{$k});
      $v =~ s@=@%3D@g;
      $v =~ s@;@%3B@g;
      $val.="$k=$v;"
    }
    $domaindb->put($d, $val);
    $domaindb->sync();
    debug("Refreshed (seen before): %s", $domain);
    return(0);
  }
  if (exists($domain{$domain})) {
    debug("Ignored (redundant): %s", $url);
    return(0);
  }
  if (exists($domainexception{$domain}) && !exists($include{$url})) {
    debug("Ignored (domainexception): %s", $url);
    return(0);
  }
  $u = $url;
  $v = 0;
  if ($urldb->seq($u,$v,R_CURSOR) == 0 && lc($u) eq lc($url)) {
    my %data = split(/[=;]/, $v);
    $data{last} = $checkpoint;
    $data{ttl} = $url_ttl*86400;
    $val="";
    while(($k,$v) = each(%data)) {
      next unless($k && $keys{$k});
      $v =~ s/=/%3D/g;
      $v =~ s/;/%3B/g;
      $val.="$k=$v;"
    }
    $urldb->put($u, $val);
    $urldb->sync();
    debug("Refreshed (seen before): %s", $url);
    return(0);
  }
  if (exists($url{$url})) {
    debug("Ignored (redundant): %s", $url);
    return(0);
  }
  info("Adding new url: %s (referer=%s)", $url, $referer);
  my $id = int(rand(2147483647));
  $k = $url;
  $v = 0;
  for ($n = $urldb->seq($k,$v,R_CURSOR);
       $n == 0 && urlmatch($k,$url) == 0;
       $k = $url, $n = $urldb->seq($k,$v,R_CURSOR)) {
    my %data = split(/[=;]/, $v || "");
    info("Removing redundant url: %s", $k);
    $urldb->del_dup($k,$v);
    $urldb->sync();
    release($data{referer}) unless(lc($data{referer}) eq lc($referer));
  }
  $referer =~ s/=/%3D/g;
  $referer =~ s/;/%3B/g;
  $v = $url_ttl*86400;
  $urldb->put($url, "last=$checkpoint;ttl=$v;found=$checkpoint;referer=$referer;id=$id;");
  $urldb->sync();
  return(1);
}

sub addresses($$) {
  my ($resolver,$host) = @_;
  my (%addresses,$socket,$select,@ready,$rr,$address);
  return(undef) if($host =~ /^\d+\.\d+\.\d+\.\d+$/);
  $socket = $resolver->bgsend($host);
  $select = new IO::Select($socket);
  @ready = $select->can_read($dns_timeout);
  foreach(@ready) {
    foreach $rr (($resolver->bgread($socket))->answer) {
      if ($rr->type eq "A") {
	$addresses{$rr->address}++;
      } elsif ($rr->type eq "CNAME") {
	foreach $address (addresses($resolver, $rr->cname)) {
	  $addresses{$address}++;
	}
      }
    }
  }
  $select->remove($socket);
  return(keys(%addresses));
}

sub washdomains() {
  my ($key,$val,$status,%redundant);
  status("Checking the domain list for redundancy..");
  undef($domaindb);
  untie(%domain);
  $DB_BTREE->{compare} = \&domaincmp;
  $domaindb = tie(%domain,"DB_File","$domains.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$domains.db: $!");
  $key = $val = 0;
  for ($status = $domaindb->seq($key, $val, R_FIRST);
       $status == 0;
       $status = $domaindb->seq($key, $val, R_NEXT)) {
    my %data = split(/[=;]/, $val || "");
    my ($host,$domain) = split(/\./, $key, 2);
    if($domain && exists($domain{$domain})) {
      info("Ooops! Removing redundant domain: %s", $key);
      release($data{referer});
      $redundant{$key} = $val;
    }
  }
  while(($key,$val) = each(%redundant)) {
    $domaindb->del_dup($key,$val);
    $domaindb->sync();
  }
  $DB_BTREE->{compare} = \&domainmatch;
  $domaindb = tie(%domain,"DB_File","$domains.db",O_CREAT|O_RDWR,0664,$DB_BTREE)
    || error("$domains.db: $!");
  $now = time;
  status("Removed %d redundant of %d domains in %s",
         scalar(keys(%redundant)), scalar(keys(%domain)),
	 strtime($now-$checkpoint));
  $checkpoint = $now;
}

sub washurls() {
  my ($status,$key,$val,%data,$domain,%redundant);
  status("Checking the url list for redundancy..");
  $key = $val = 0;
  for ($status = $urldb->seq($key, $val, R_FIRST);
       $status == 0;
       $status = $urldb->seq($key, $val, R_NEXT)) {
    $domain = $key;
    $domain =~ s@/.*@@;
    %data = split(/[=;]/, $val);
    if(exists($domain{$domain})) {
      my %d = split(/[=;]/, $domain{$domain});
      release($data{referer}) unless(lc($data{referer}) eq lc($d{referer}));
      $redundant{$key} = $val;
    } else {
      my $k = $key;
      $k =~ s@/[^/]+/?$@@;
      if(exists($url{$k})) {
	my %u = split(/[=;]/, $url{$k});
	release($data{referer}) unless(lc($data{referer}) eq lc($u{referer}));
	$redundant{$key} = $val;
      }
    }
  }
  while(($key,$val) = each(%redundant)) {
    info("Removing redundant url: %s", $key);
    $urldb->del_dup($key,$val);
    $urldb->sync();
  }
  $now = time;
  status("Removed %d redundant of %d urls in %s",
         scalar(keys(%redundant)), scalar(keys(%url)), strtime($now-$checkpoint));
  $checkpoint = $now;
}

sub wash() {
  washdomains();
  washurls();
  washlinks();
}

sub compile($) {
  my $from = shift;
  status("Compiling..");
  my ($resolver,$key,$val,%data,$domain,$path,$url,$host,$k,$v);
  my ($domains,$urls) = (0,0);
  if ($doinaddr) {
    $resolver = new Net::DNS::Resolver;
    $resolver->nameservers(@nameservers) if(@nameservers);
  }
  while(($key,$val) = each(%link)) {
    %data = split(/[=;]/, $val || "");
    $data{used} = 0 unless($data{used});
    $data{found} = $start unless($data{found});
    next if($data{used} > 0 && $from);
    next if($data{found} < $from);
    ($domain,$path,$url,$host) = spliturl($key);
    if ($path && $path ne "" && $path ne "/") {
      my ($u,$s,$done) = ("", "", 0);
      foreach $k (split(/\057/, $url)) {
        next unless($k);
        $u .= $s . $k;
        $s = "/";
	study($k) if(@patterns > 5);
        foreach(@patterns) {
	  print "Checking: $url: $u\n";####
	  if ($k =~ /$_/i && (exists($include{$u}) || !exists($exception{$u}))) {
	    if ($u =~ /\057/) {
	      debug("addurl(%s,%s,%s)",$domain,$u,$key);
    	      $urls++ if (($data{used} = addurl($domain,$u,$key)));
	      if ($doinaddr && $host !~ /^\d+\.\d+\.\d+\.\d+$/) {
		my $path = $u;
		$path =~ s@^[^/]+@@;
		foreach (addresses($resolver,$host)) {
		  $u = $_ . $path;
		  debug("addurl(%s,%s,%s)",$domain,$u,$key);
		  $urls++ if (($data{used} += addurl($domain,$u,$key)));
		}
	      }
  	    } else {
	      my @elements = split(/\./, $domain);
	      my $d = pop(@elements);
	      if ($host =~ /^\d+\.\d+\.\d+\.\d+$/) {
		$d = $domain;
	      } else {
		while(@elements) {
		  $d = pop(@elements) . ".$d";
		  print "Checking: $domain: $d\n";####
		  if($d =~ /$_/i) {
		    last if(exists($include{$d}));
		    next if(exists($domainexception{$d}) || exists($exception{$d}));
		    last;
		  }
		}
	      }
	      debug("adddomain(%s,%s)",$d,$key);
	      $domains++ if (($data{used} = adddomain($d,$key)));
	      if ($doinaddr && $host !~ /^\d+\.\d+\.\d+\.\d+$/) {
		foreach (addresses($resolver,$host)) {
		  debug("adddomain(%s,%s)",$_,$key);
		  $domains++ if (($data{used} += adddomain($_,$key)));
		}
	      }
	    }
	    $done++;
  	    last;
	  }
        }
	last if($done);
      }
      unless($done) {
        $urls++ if (($data{used} = addurl($domain,$url,$key)));
      }
    } else {
      my $done = 0;
      my @elements = split(/\./, $domain);
      my $d = pop(@elements);
      if ($host =~ /^\d+\.\d+\.\d+\.\d+$/) {
	$d = $domain;
      } else {
	while(@elements) {
	  $d = pop(@elements) . ".$d";
	  print "Checking: $domain: $d\n";####
	  foreach(@patterns) {
	    if($d =~ /$_/i) {
	      if(exists($include{$d})) {
		$done++;
		last;
	      }
	      next if(exists($domainexception{$d}) || exists($exception{$d}));
	      $done++;
	      last;
	    }
	  }
	}
      }
      debug("adddomain(%s,%s)",$d,$key);
      $domains++ if (($data{used} = adddomain($d,$key)));
      if ($doinaddr && $host !~ /^\d+\.\d+\.\d+\.\d+$/) {
	foreach (addresses($resolver,$host)) {
	  debug("adddomain(%s,%s)",$_,$key);
	  $domains++ if (($data{used} += adddomain($_,$key)));
	}
      }
    }
    $val="";
    while(($k,$v) = each(%data)) {
      next unless($k && $keys{$k});
      $v =~ s/=/%3D/g;
      $v =~ s/;/%3B/g;
      $val.="$k=$v;"
    }
    $linkdb->put($key, $val);
    $linkdb->sync();
  }
  $domaindb->sync();
  $urldb->sync();
  $linkdb->sync();
  $now = time;
  status("Compiled %d links into %d domains and %d urls in %s",
	 scalar(keys(%link)), scalar(keys(%domain)), scalar(keys(%url)),
	 strtime($now-$checkpoint));
  status("Added %d new domains and %d new urls", $domains, $urls);
  $checkpoint = $now;
}

sub today() {
  my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
  return(sprintf("%4d%02d%02d\n",$year+1900,$mon+1,$mday));
}

sub export() {
  my ($k,$n);
  $checkpoint = time;
  status("Dumping the domainlist..");
  ($k,$n) = dumpkeys($domaindb, $domainlist, "$newdomains." . today());
  $now = time;
  status("Dumped %d keys of which %d new to the domainlist in %s..",
	 $k,$n,strtime($now-$checkpoint));
  $checkpoint = $now;
  status("Dumping the urllist..");
  ($k,$n) = dumpkeys($urldb, $urllist, "$newurls." . today());
  $now = time;
  status("Dumped %d keys of which %d new to the urllist in %s..",
	 $k,$n,strtime($now-$checkpoint));
  $checkpoint = $now;
}

sub valid($) {
  my $db = shift;
  my ($status, $key, $val, %data);
  my $n = 0;
  $key = $val = 0;
  for ($status = $db->seq($key, $val, R_FIRST);
       $status == 0;
       $status = $db->seq($key, $val, R_NEXT)) {
    %data = split(/[=;]/, $val || "");
    $n++ if($data{last} && $data{last} > 0);
  }
  return($n);
}

sub dumpkeys($$$) {
  my ($db, $list,$news) = @_;
  my ($status, $key, $val, %data, $k, $n);
  open(LIST, ">$list") || error("$list: $!");;
  open(NEWS, ">>$news") || error("$news: $!");;
  $key = $val = $k = $n = 0;
  print LIST "#\n";
  print LIST "# !!! WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING !!!\n";
  print LIST "#\n";
  print LIST "# This list is entierly a product of a dumb robot ($progname-$VERSION).\n";
  print LIST "# We strongly recommend that you review the lists before using them!\n";
  print LIST "# Don't blame us if there are mistakes, but please report errors with\n";
  print LIST "# the online tool at http://www.squidguard.org/blacklist/\n";
  print LIST "#\n";
  print LIST "# !!! WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING !!!\n";
  print LIST "#\n";
  printf LIST "# This list was compiled in %s on %s.\n",
  strtime(time-$start), date(time);
  printf LIST "# This list was compiled from %d sources and %d links,\n",
  valid($sourcedb), scalar(keys(%link));
  printf LIST "# of which %d tested successfully.\n", valid($linkdb);
  print LIST "#\n";
  for ($status = $db->seq($key, $val, R_FIRST);
       $status == 0;
       $status = $db->seq($key, $val, R_NEXT)) {
    $k++;
    print LIST "$key\n";
    %data = split(/[=;]/, $val || "");
    if($data{found} && $data{found} > $start) {
      $n++;
      print NEWS "$key\n";
    }
  }
  close(NEWS);
  close(LIST);
  return(($k,$n));
}

sub end($) {
  my $exit = shift;
  $exit = -1 unless(defined($exit));
  if ($exit =~ /^[A-Z]+$/) {
    $SIG{$exit} = "IGNORE";
    status("Got %s signal..", $exit);
    status("Cleaning up..");
  }
  if($domaindb && $urldb && $linkdb) {
    export();
  }
  if($sourcedb) {
    undef($sourcedb);
    untie(%source);
  }
  if($candidatedb) {
    dumpcandidates();
    undef($candidatedb);
    untie(%candidate);
  }
  if($linkdb) {
    undef($linkdb);
    untie(%link);
  }
  if($domaindb) {
    undef($domaindb);
    untie(%domain);
  }
  if($urldb) {
    undef($urldb);
    untie(%url);
  }
  if($domainexceptiondb) {
    undef($domainexceptiondb);
    untie(%domainexception);
  }
  if($urlexceptiondb) {
    undef($urlexceptiondb);
    untie(%urlexception);
  }
  if($exceptiondb) {
    undef($exceptiondb);
    untie(%exception);
  }
  if($redirectordb) {
    undef($redirectordb);
    untie(%redirector);
  }
  if ($exit =~ /^[A-Z]+$/) {
    status("Killed by a %s signal.", $exit);
    $exit = $signal{$exit} || -2;
  }
  $exit = -3 unless($exit =~ /^\d+$/);
  status("Total runtime %s", strtime(time-$start));
  exit($exit);
}

#
# NOW JUST DO IT:
#
init();
#expire();
#load();
#extract();
compile(0);
#$from = $checkpoint;
#check();
#compile($from);
#wash();
#end(0);
