#!/usr/bin/perl
#------------------------------------------------------------------------------
# Project     : portscout
# Author      : Shaun Amott <shaun@inerd.com>
# Start date  : 2006-01-07
# Environment : perl 5.8.x, PostgreSQL 7.4, FreeBSD 6.x
# Download    : http://www.inerd.com/software/portscout/
#
# $Id: portscout.pl,v 1.46 2008/01/24 04:10:35 samott Exp $
#------------------------------------------------------------------------------
# Copyright (C) 2005-2008, Shaun Amott. All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#------------------------------------------------------------------------------

use IO::Handle;
use File::Basename;
use File::Copy;
use Socket;
use POSIX;
use Fcntl;

use Getopt::Long;
use Proc::Queue;
use Sys::Hostname;
use LWP::UserAgent;
use MIME::Lite;
use Net::FTP;

use DBI;

use Portscout;

use strict;
#use warnings;

require 5.006;

use constant {
	APPNAME     		=> 'portscout',
	APPVER      		=> '0.7.4',
	AUTHOR      		=> 'Shaun Amott',

	USER_AGENT  		=> 'portscout/0.7.4',

	DB_VERSION  		=> 2008012301,

	MAX_PATH    		=> 1024,

	PREFIX      		=> '/usr/local',
	CONFIG_FILE 		=> 'portscout.conf',

	METHOD_GUESS		=> 1,
	METHOD_LIST 		=> 2,

	ROBOTS_ALLOW   		=> 0,
	ROBOTS_UNKNOWN 		=> 1,
	ROBOTS_BLANKET 		=> 2,
	ROBOTS_SPECIFIC		=> 3,

	TYPE_INT    		=> 1,
	TYPE_BOOL   		=> 2,
	TYPE_STRING 		=> 3,
};


#------------------------------------------------------------------------------
# Default Configuration Options
#------------------------------------------------------------------------------

my (%settings, @paths, %settings_types, $bool_opts);
my ($index_file, $num_ports);

# Useful settings

%settings = (
	ports_dir       	=> '/usr/ports',
	templates_dir   	=> 'templates',
	ms_data_dir     	=> '_data',
	html_data_dir   	=> '_html',
	sup_data_dir    	=> '_supdata',

	cache_ms_data   	=> 0, 		# Keep mastersite data (wasteful)
	cache_sup_data  	=> 1, 		# Keep old supdata (could be useful)
	precious_data   	=> 0, 		# Don't write anything to database
	num_children    	=> 15,		# Number of child processes to spawn
	workqueue_size  	=> 20,		# Size of work queue per child
	ftp_retries     	=> 3, 		# Retry on "connections-per-IP" failures
	ftp_passive     	=> 1, 		# Use passive FTP where possible
	ftp_timeout     	=> 42,		# FTP timeout, in seconds
	http_timeout    	=> 22,		# HTTP timeout, in seconds

	robots_enable   	=> 1,
	robots_checking 	=> 'strict',

	local_timezone  	=> 'GMT',

	portconfig_enable  	=> 1,
	freebsdhacks_enable	=> 1,

	default_html_sort  	=> 'maintainer',

	version_compare 	=> 'internal',

	db_user         	=> APPNAME,
	db_name         	=> APPNAME,
	db_connstr      	=> 'DBI:Pg:dbname='.APPNAME,

	mail_enable     	=> 1,
	mail_from       	=> APPNAME,
	mail_subject    	=> '',
	mail_method     	=> 'sendmail',
	mail_host       	=> 'localhost',

	cluster_enable  	=> 0,
	system_affinity 	=> 0,

	user            	=> '',
	group           	=> '',

	debug           	=> 0,
	quiet           	=> 0,
);

# Roughly work out variable types

$bool_opts = 'ftp_passive|system_affinity|debug|quiet';

foreach (keys %settings) {
	if (/^(?:.+_enable|.+_data|$bool_opts)$/) {
		$settings_types{$_} = TYPE_BOOL;
	} elsif ($settings{$_} =~ /^\d+$/) {
		$settings_types{$_} = TYPE_INT;
	} else {
		$settings_types{$_} = TYPE_STRING;
	}
}

@paths = ('.', '/etc', PREFIX.'/etc');

# Override defaults with config file

ParseConfigFile(CONFIG_FILE, \@paths, \%settings)
    or die "Unable to parse config file";


#------------------------------------------------------------------------------
# SQL Queries
#------------------------------------------------------------------------------

my %sql;

# BuildPortsDB

$sql{portdata_count} =
	q(SELECT COUNT(*)
	    FROM portdata
	   WHERE name = ?
	     AND cat = ?
	     AND moved != true);

$sql{portdata_getver} =
	q(SELECT ver
	    FROM portdata
	   WHERE name = ?
	     AND cat = ?
	     AND moved != true);

$sql{portdata_clearnewver} =
	q(UPDATE portdata
	     SET newver = NULL, method = NULL
	   WHERE name = ?
	     AND cat = ?
	     AND moved != true);

$sql{portdata_update} =
	q(UPDATE portdata
	     SET ver = ?,  comment = ?,     cat = ?,         dir = ?,
	         home = ?, distfiles = ?,   distname = ?,
	         sufx = ?, mastersites = ?, maintainer = ?,  masterport = ?,
	         updated = CURRENT_TIMESTAMP
	   WHERE name = ?
	     AND cat = ?
	     AND moved != true);

$sql{portdata_insert} =
	q(INSERT
	    INTO portdata (name, distname, ver, comment, cat,
	         dir, home, distfiles, sufx, mastersites,
	         maintainer, method, masterport)
	  VALUES (?,?,?,?,?,?,?,?,?,?,?,0,?));

$sql{portdata_masterport_str2id} =
	q(UPDATE portdata
	     SET masterport_id = (SELECT id
	                            FROM portdata
	                              AS master
	                           WHERE master.cat  = split_part(portdata.masterport, '/', 1)
	                             AND master.name = split_part(portdata.masterport, '/', 2)
	                           LIMIT 1)
	   WHERE masterport is not NULL
	     AND masterport != ''
	     AND moved != true);

$sql{portconfig_update} =
	q(UPDATE portdata
	     SET indexsite = ?, limitver = ?,     limiteven = ?,
	         skipbeta = ?,  skipversions = ?, limitwhich = ?
	   WHERE name = ?
	     AND cat = ?
	     AND moved != true);

$sql{portconfig_isstatic} =
	q(SELECT pcfg_static
	    FROM portdata
	   WHERE name = ?
	     AND cat = ?
	     AND moved != true);

# BuildPortsDBFast

$sql{portdata_findslaves} =
	q(SELECT name, cat
	    FROM portdata
	   WHERE masterport_id = (SELECT id
	                            FROM portdata
	                           WHERE name = ?
	                             AND cat = ?
	                           LIMIT 1)
	     AND moved != true);

# CheckPortsDB

$sql{portdata_select} =
	q(SELECT *
	    FROM portdata
	   WHERE ( age(checked) > '2 hours' OR checked is NULL )
	     AND ( masterport_id = 0 OR masterport_id is NULL )
	     AND ( systemid = (SELECT id
	                         FROM systemdata
	                        WHERE host = ?
	                        LIMIT 1)
	           OR systemid is NULL )
	     AND moved != true
	ORDER BY random());
#	     AND ( newver = ver OR newver is NULL )

$sql{portdata_setchecked} =
	q(UPDATE portdata
	     SET checked = CURRENT_TIMESTAMP
	   WHERE id = ?
	      OR masterport_id = ?);

$sql{portdata_setnewver} =
	q(UPDATE portdata
	     SET newver = ?, method = ?, newurl = ?
	   WHERE id = ?
	      OR masterport_id = ?);

$sql{sitedata_count} =
	q(SELECT COUNT(*)
	    FROM sitedata
	   WHERE host = ?);

$sql{sitedata_select} =
	q(SELECT host, robots, robots_paths, (CURRENT_TIMESTAMP >= robots_nextcheck) AS robots_outofdate
	    FROM sitedata
	   WHERE position(host in ?) > 0
	     AND ignore is not true
	ORDER BY failures ASC);
#	ORDER BY type ASC, failures ASC);

$sql{sitedata_failure} =
	q(UPDATE sitedata
	     SET failures = failures + 1
	   WHERE host = ?);

$sql{sitedata_success} =
	q(UPDATE sitedata
	     SET successes = successes + 1
	   WHERE host = ?);

$sql{sitedata_insert} =
	q(INSERT
	    INTO sitedata (type, host)
	  VALUES (?,?));

$sql{sitedata_initliecount} =
	q(UPDATE sitedata
	     SET liecount = 8
	   WHERE host = ?);

$sql{sitedata_decliecount} =
	q(UPDATE sitedata
	     SET liecount = liecount - 1
	   WHERE host = ?);

$sql{sitedata_setrobots} =
	q(UPDATE sitedata
	     SET robots = ?,
	         robots_paths = ?,
	         robots_nextcheck = CURRENT_TIMESTAMP + INTERVAL '2 weeks'
	   WHERE host = ?);

# UncheckPortsDB

$sql{portdata_uncheck} =
	q(UPDATE portdata
	     SET checked = NULL, newver = NULL, status = NULL,
	         newurl = NULL,  method = NULL);

# GenerateHTML

$sql{portdata_genresults} =
	q(SELECT *
	    INTO TEMP _results
	    FROM (SELECT DISTINCT
	              ON (lower(maintainer)) lower(maintainer) AS maintainer,
	                                     COUNT(maintainer) AS withnewdistfile
	            FROM portdata
	           WHERE newver != ver
	             AND newver is not NULL
	             AND moved != true
	           GROUP BY lower(maintainer))
	      AS pd1;
	
	  SELECT maintainer, total,
	         COALESCE (withnewdistfile, 0) AS withnewdistfile,
	         CAST (100*(withnewdistfile*1.0/total*1.0) AS FLOAT) AS percentage
	    INTO TEMP results
	    FROM (SELECT DISTINCT
	              ON (lower(maintainer)) lower(maintainer) AS maintainer,
	                                     COUNT(maintainer) AS total
	            FROM portdata
	           WHERE moved != true
	           GROUP BY lower(maintainer))
	      AS pd2
	    LEFT JOIN _results
	   USING (maintainer));

$sql{portdata_selectall} =
	q(SELECT *
	    FROM portdata
	   WHERE lower(maintainer) = lower(?)
	     AND moved != true
	ORDER BY cat,name);

$sql{portdata_selectall_limited} =
	q(SELECT name, cat, limitver, limiteven, limitwhich, indexsite, skipversions
	    FROM portdata
	   WHERE ( limitver     is not NULL )
	      OR ( limitwhich   is not NULL )
	      OR ( indexsite    is not NULL )
	      OR ( skipversions is not NULL )
	     AND moved != true
	ORDER BY cat,name);

# MovePorts

$sql{moveddata_exists} =
	q(SELECT COUNT(id)
	    FROM moveddata
	   WHERE fromport = ?
	     AND toport = ?
	     AND date = ?
	   LIMIT 1);

$sql{moveddata_insert} =
	q(INSERT
	    INTO moveddata (fromport, toport, date, reason)
	  VALUES (?,?,?,?));

$sql{portdata_move} =
	q(UPDATE portdata
	     SET cat = ?, name = ?
	   WHERE cat = ?
	     AND name = ?
	     AND moved != true);

$sql{portdata_setmoved} =
	q(UPDATE portdata
	     SET moved = true
	   WHERE name = ?
	     AND cat = ?);

$sql{portdata_removestale} =
	q(DELETE
	    FROM portdata
	   WHERE moved = true
	     AND pcfg_static != true);

$sql{portdata_exists} =
	q(SELECT COUNT(id)
	    FROM portdata
	   WHERE name = ?
	     AND cat = ?
	   LIMIT 1);

# MailMaintainers

$sql{maildata_select} =
	q(SELECT address
	    FROM maildata);

$sql{portdata_findnewnew} =
	q(SELECT name,cat,ver,newver
	    FROM portdata
	   WHERE lower(maintainer) = lower(?)
	     AND newver != ver
	     AND newver is not NULL
	     AND moved != true
	     AND ignore != true
	     AND (( mailed != ver AND mailed != newver )
	            OR mailed is NULL )
	ORDER BY cat,name ASC);

$sql{portdata_setmailed} =
	q(UPDATE portdata
	     SET mailed = ?
	   WHERE name = ?
	     AND cat = ?
	     AND moved != true);

# AllocatePorts

$sql{portdata_countleft} =
	q(SELECT COUNT(*)
	    FROM portdata
	   WHERE moved != true
	     AND systemid is NULL);

$sql{portdata_deallocate} =
	q(UPDATE portdata
	     SET systemid = NULL);

$sql{allocators_count} =
	q(SELECT COUNT(*)
	    FROM allocators
	   LIMIT 1);

$sql{allocators_select} =
	q(SELECT *
	    FROM allocators
	ORDER BY seq ASC, allocator);

# Misc.

$sql{portscout_version} =
	q(SELECT dbver
	    FROM portscout
	ORDER BY dbver DESC
	   LIMIT 1);


#------------------------------------------------------------------------------
# Globals
#------------------------------------------------------------------------------

my (@db_connect_args, $date_regex, $beta_regex, $month_regex, $ext_regex);

my @bad_versions;

my $make_cache;

@db_connect_args = ($settings{db_connstr}, $settings{db_user},
                    $settings{db_pass});

$month_regex = 'Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec';
$date_regex  = '(?<!\d)\d{4}([\-\.]?)(?:\d{2}|'.$month_regex.')\1\d{2}(?!\d)';

$beta_regex  = 'alpha|beta|pre.*|rc|unstable|dev|test';

$ext_regex   = '\.tar\.gz|\.tar\.bz2|\.tgz\|\.zip';

@bad_versions =
	qw(win32 cygwin linux osx hpux irix hp-ux hp_ux solaris
	   hp-ux irix mac-?os darwin aix macintosh manual docs?
	   examples sunos tru64 rh\d-rpm suse sun4[a-z]? cvs snap
	   win jdk i[3-6]86 theme nolib dyn lin(?:ux)?(?:\d\d)?);


#-------------------------------------------------------------------------------
# Signal Handlers
#-------------------------------------------------------------------------------

sub terminate
{
	local $SIG{INT} = 'IGNORE';
	kill('TERM', -$$);

	print "PID #$$ Terminating...\n";
	exit 1;
}

sub reaper
{
	my $child;
	(1) while (($child = waitpid(-1, WNOHANG)) > 0);
	$SIG{CHLD} = \&reaper;
}

$SIG{INT}  = \&terminate;
$SIG{TERM} = \&terminate;
#$SIG{CHLD} = \&reaper;
$SIG{PIPE} = 'IGNORE';


#------------------------------------------------------------------------------
# Begin Code
#------------------------------------------------------------------------------

main();


#------------------------------------------------------------------------------
# Func: main()
# Desc: Pseudo script entry-point.
#
# Args: n/a
#
# Retn: n/a
#------------------------------------------------------------------------------

sub main
{
	GetOptions(
		%{&{sub {
			my %s;
			foreach (keys %settings) {
				my ($t, $c);
				$t = $settings_types{$_} || TYPE_STRING;

				if ($t == TYPE_BOOL) {
					$c = '!';
				} elsif ($t == TYPE_INT) {
					$c = '=i';
				} else {
					$c = '=s';
				}

				$s{$_.$c} = \$settings{$_};
			}
			return \%s;
		}}}
	) or exit 1;

	if ($settings{debug}) {
		print STDERR '-' x 72 . "\n";
		print STDERR "Using settings:\n";
		print STDERR "  Variable: $_ -> $settings{$_}\n"
			foreach (keys %settings);
		print STDERR '-' x 72 . "\n";
	}

	Usage() if (!defined $ARGV[0]);

	if ($ARGV[0] eq 'debug')
	{
		if ($#ARGV == 3 and $ARGV[1] eq 'vercompare')
		{
			my $res;
			print 'vercompare: ';
			if ($ARGV[2] eq $ARGV[3]) {
				$res = '=';
			} elsif (vercompare($ARGV[2], $ARGV[3])) {
				$res = '>';
			} else {
				$res = '<';
			}
			print "$ARGV[2] $res $ARGV[3]\n";

			exit 0;
		} else {
			Usage();
		}
	}

	print APPNAME.' v'.APPVER.', by '.AUTHOR."\n\n";

	SwitchUser();

	if (getdbver() < DB_VERSION) {
		# Newer versions are probably okay
		print STDERR "Database schema out of date: please upgrade.\n";
		exit 1;
	}

	CheckIndex() or die 'Index file not found';

	InitMakeCache($settings{ports_dir}, qw(OSVERSION OSREL PORTOBJCFORMAT
	              ARCH OPSYS UID PKGINSTALLVER CONFIGURE_MAX_CMD_LEN));

	print "Found $num_ports ports\n\n";

	exit (ExecArgs($ARGV[0]) ? 0 : 1);
}


#------------------------------------------------------------------------------
# Func: ExecArgs()
# Desc: Initiate primary operation requested by user.
#
# Args: $cmd    				- Command to execute
#
# Retn: $success				- true/false
#------------------------------------------------------------------------------

sub ExecArgs
{
	my ($cmd) = @_;

	my $res;

	if ($cmd eq 'build')
	{
		print "-- [ Building ports database ] -----------------------------------------\n\n";
		$res = BuildPortsDB() && MovePorts(1);
	}
	elsif ($cmd eq 'check')
	{
		print "-- [ Checking ports distfiles ] ----------------------------------------\n\n";

		Proc::Queue::size($settings{num_children});
		$res = CheckPortsDB();
	}
	elsif ($cmd eq 'generate')
	{
		Portscout::Template->templatedir($settings{templates_dir});
		Portscout::Template->outputdir($settings{html_data_dir});

		$res = GenerateHTML();
	}
	elsif ($cmd eq 'rebuild')
	{
		$res = BuildPortsDBFast();
	}
	elsif ($cmd eq 'mail')
	{
		Portscout::Template->templatedir($settings{templates_dir});

		if ($settings{mail_method} ne 'sendmail') {
			MIME::Lite->send($settings{mail_method}, $settings{mail_host});
		}

		$res = MailMaintainers();
	}
	elsif ($cmd eq 'uncheck')
	{
		$res = UncheckPortsDB();
	}
	elsif ($cmd eq 'addmoved')
	{
		$res = MovePorts(1);
	}
	elsif ($cmd eq 'fixmoved')
	{
		$res = MovePorts(0);
	}
	elsif ($cmd eq 'allocate')
	{
		$res = AllocatePorts();
	}
	else
	{
		Usage();
	}

	return $res;
}


#------------------------------------------------------------------------------
# Func: BuildPortsDB()
# Desc: Loop through all ports and construct a psuedo database of all the
#       information we need. In particular, names, versions and distfiles.
#
# Args: \@only_ports		- List of ports to build (otherwise, all of them)
#
# Retn: $success    		- true/false
#------------------------------------------------------------------------------

sub BuildPortsDB
{
	my ($only_ports) = @_;

	my (%sths, $dbh, $real_cats, $mv);

	my $error     = 0;
	my $ports_got = 0;

	# Restriction list provided, but empty
	return if (defined $only_ports and !exists $only_ports->[0]);

	$dbh = DBI->connect(@db_connect_args) or die DBI->errstr;

	prepare_sql(\$dbh, \%sths, qw(portdata_count portdata_update portdata_insert
	            sitedata_count sitedata_insert portdata_getver portdata_clearnewver
	            portdata_masterport_str2id portconfig_update portconfig_isstatic));

	# Get list of primary (real) categories

	$real_cats = makevar($settings{ports_dir}, 'SUBDIR');

	open my $if, "<$index_file" or $error = 1;

	while (<$if>)
	{
		my ($ver, $distname, $distfiles, $sufx, $sites, $subdir,
		    $distver, $masterport, $cat);
		my ($name, $dir, undef, $comment, undef, $maintainer, $cats, undef,
		    undef, $home, undef, undef) = split (/\|/);

		# Determine provisional name and version

		($name, $ver) = ($1, $2) if ($name =~ /^(.*)-(.*)$/);

		# Take first category (which should be real)

		$cat = $cats;
		$cat =~ s/^\s*(\S+).*/$1/;

		# Check restriction lists

		next unless checkrestricted($name, $cat, $maintainer);

		# It turns out UNIQUENAME isn't actually unique; therefore,
		# we'll use the port's sub-directory name for now.

		$name = $dir and $name =~ s/^.*\/(.+?)$/$1/;

		# Build only ports that have been updated

		if (defined $only_ports) {
			next if (@$only_ports && !grep /^\Q$cat\E\/\Q$name\E$/, @$only_ports);
		}

		$ports_got++;

		print '[' . strchop($cat, 15) . '] ';
		info($name, "(got $ports_got out of $num_ports)");

		# Query make for variables -- this is a huge bottleneck

		$mv = makevar($dir, qw(UNIQUENAME DISTNAME DISTFILES
		                       EXTRACT_SUFX MASTER_SITES
		                       MASTER_SITE_SUBDIR DISTVERSION
		                       SLAVE_PORT MASTER_PORT PORTSCOUT));

		$mv->{$_} =~ s/\s+/ /g foreach (keys %$mv);

		$distname  = $mv->{DISTNAME}           || '';
		$distfiles = $mv->{DISTFILES}          || '';
		$sufx      = $mv->{EXTRACT_SUFX}       || '';
		$sites     = $mv->{MASTER_SITES}       || '';
		$subdir    = $mv->{MASTER_SITE_SUBDIR} || '';
		$distver   = $mv->{DISTVERSION}        || '';

		$masterport = (lc $mv->{SLAVE_PORT} eq 'yes') ? $mv->{MASTER_PORT} : '';

		$masterport = $1 if ($masterport =~ /^\Q$settings{ports_dir}\E\/(.*)\/$/);

		# Get rid of unexpanded placeholders

		$sites =~ s/\%SUBDIR\%/$subdir/g;

		# Remove ports-system "site group" specifiers
		# XXX: probably ought to allow initial number

		$sites     =~ s/:[A-Za-z][A-Za-z0-9\,]*\s*/ /g;
		$distname  =~ s/:[A-Za-z][A-Za-z0-9\,]*$//g;
		$distfiles =~ s/:[A-Za-z][A-Za-z0-9\,]*\s*/ /g;

		# Attempt to extract real version from
		# distname (this needs refining)

		if ($distver)
		{
			$ver = $distver;
		}
		elsif ($distname =~ /\d/)
		{
			my $name_q;
			$ver = $distname;
			$name_q = quotemeta $name;

			$name_q =~ s/^(p5|mod|py|ruby)(?:[\-\_])/($1\[\\-\\_\])?/;

			# XXX: fix me

			my $chop = 'sources?|bin|src|snapshot|freebsd\d*|freebsd-?\d\.\d{1,2}|' .
			           'linux|unstable|elf|i\d86|x86|sparc|mips|linux-i\d86|html|'  .
			           'en|en_GB|en_US|full-src|orig|setup|install|export|'         .
			           'fbsd[7654]\d{1,2}|export|V(?=\d)';
			foreach (split '\|', $chop) {
				unless ($name =~ /($_)/i) {
					$ver =~ s/[\.\-\_]?($chop)$//gi;
					$ver =~ s/^($chop)[\.\-\_]?//gi;
				}
			}

			unless ($ver =~ s/.*$name_q[-_\.]//i) {
				# Resort to plan B
				if ($ver =~ /^(.*)-(.*)$/) {
					$ver = $2;
				} elsif ($name !~ /\d/) {
					$ver =~ s/^\D*(\d.*)$/$1/;
				}
			}

			$ver = '' if ($ver eq $name);
		}

		# Store port data

		if ($name && !$settings{precious_data})
		{
			my $nrows;
			$sths{portdata_count}->execute($name, $cat);
			$nrows = $sths{portdata_count}->fetchrow_arrayref->[0];

			if ($nrows > 0)
			{
				my $oldver;

				# Clear newver if current version changed.
				$sths{portdata_getver}->execute($name, $cat);
				$oldver = $sths{portdata_getver}->fetchrow_arrayref->[0];
				if ($oldver ne $ver) {
					$sths{portdata_clearnewver}->execute($name, $cat);
				}

				$sths{portdata_update}->execute(
					$ver, $comment, $cat, $dir, $home, $distfiles, $distname,
					$sufx, $sites, $maintainer, $masterport, $name, $cat
				);
			}
			else
			{
				$sths{portdata_insert}->execute(
					$name, $distname, $ver, $comment, $cat, $dir, $home,
					$distfiles, $sufx, $sites, $maintainer, $masterport
				);
			}
		}

		if ($settings{portconfig_enable} && !$settings{precious_data}) {
			my $iss;
			$sths{portconfig_isstatic}->execute($name, $cat);
			$iss = $sths{portconfig_isstatic}->fetchrow_arrayref->[0];

			if (!$iss) {
				my %pcfg;

				foreach (split /\s+/, $mv->{PORTSCOUT}) {
					my ($var, $val);
					if (/^([A-Za-z]+):(.*)$/i) {
						$var = lc $1; $val = $2;

						if ($var eq 'site') {
							$pcfg{indexsite} = $val
								if ($val =~ /^(?:ftp|https?):\/\/[^\/]+/i);
							next;
						}

						if ($var eq 'limit') {
							# Check regex isn't going to explode
							eval {
								no warnings 'all';
								my $re = '';
								$re =~ /$val/;
								1;
							};

							if ($@) {
								print STDERR 'Bad regex provided by portconfig ' .
								             "variable in port $cat/$name\n";
								next;
							};

							$pcfg{limitver} = $val;
							next;
						}

						if ($var eq 'skipb') {
							if ($val == 1 or lc $val eq 'yes') {
								$pcfg{skipbeta} = 't';
							} else {
								$pcfg{skipbeta} = 'f';
							}
							next;
						}

						if ($var eq 'skipv') {
							$val =~ s/,+/ /;
							$pcfg{skipversions} = $val;
							next;
						}

						if ($var eq 'limitw') {
							$val = lc $val;
							if ($val =~ /^(\d{1,2}),(even|odd)$/i) {
								$pcfg{limitwhich} = $1;
								$pcfg{limiteven}  = $2 eq 'even' ? 't' : 'f';
							} else {
								print STDERR 'Bad limitw value provided by ' .
								             "portconfig variable in port $cat/$name\n";
							}
							next;
						}

						# We've checked for all the variables we support

						print STDERR "Unknown portconfig key ($var) found " .
						             "in port $cat/$name\n";
					} else {
						print STDERR "Invalid portconfig tuple ($_) found " .
						             "in port $cat/$name\n";
						next;
					}
				}

				# Nullify any variables we haven't accumulated
				foreach ('indexsite', 'limitver', 'skipversions', 'limiteven', 'limitwhich') {
					$pcfg{$_} = undef if (!exists $pcfg{$_});
				}

				# ...except skipbeta, which shouldn't be NULL
				$pcfg{skipbeta} = 't' if !exists($pcfg{skipbeta});

				$sths{portconfig_update}->execute(
					$pcfg{indexsite}, $pcfg{limitver}, $pcfg{limiteven}, $pcfg{skipbeta},
					$pcfg{skipversions}, $pcfg{limitwhich}, $name, $cat
				);

				# Ensure indexsite is added to sitedata
				$sites .= " $pcfg{indexsite}" if ($pcfg{indexsite});
			}
		}

		if ($sites && !$settings{precious_data})
		{
			# Add master site hosts to database
			foreach (split /\s+/, $sites)
			{
				if (/^(ftp|https?):\/\/([^\/]+)/i) {
					my $nrows;
					$sths{sitedata_count}->execute(lc $2);
					$nrows = $sths{sitedata_count}->fetchrow_arrayref->[0];

					$sths{sitedata_insert}->execute(lc $1, lc $2)
						if ($nrows == 0);
				}
			}
		}
	}

	close $if;

	# Go through and convert all masterport cat/name strings
	# into numerical ID values

	if (!$error) {
		print "\nCross-referencing master/slave ports...\n";
		$sths{portdata_masterport_str2id}->execute;
	} else {
		print STDERR "Error processing index file.\n";
	}

	finish_sql(\$dbh, \%sths);
	$dbh->disconnect;

	return ($error ? 0 : 1);
}


#------------------------------------------------------------------------------
# Func: BuildPortsDBFast()
# Desc: Re-build ports database, updating only what needs updating, using
#       output from c[v]sup to determine what has changed.
#
# Args: n/a
#
# Retn: $success				- true/false
#------------------------------------------------------------------------------

sub BuildPortsDBFast
{
	my (@ports, @files, %sths, $dbh);
	my $move_ports = 0;

	opendir my $supdir, $settings{sup_data_dir};

	my $fh;
	foreach (grep /^cvsup.*\.log$/, readdir($supdir)) {
		my $file = $_;
		push @files, $file;
		unless (open $fh, $settings{sup_data_dir}. "/$file") {
			print "Couldn't open supfile: $file\n";
			next;
		}

		while (<$fh>) {
			push @ports, $1 if (/^ \S+ ports\/(.*?\/.*?)\//);

			$move_ports = /^ \S+ ports\/MOVED$/ if (!$move_ports);
		}
	}

	# Remove duplicates

	my %s; @ports = grep(!$s{$_}++, @ports);

	# @ports is the list of ports to update

	closedir $supdir;

	if ($move_ports) { return 0 if !MovePorts(0); }

	# Add any slave ports to the list

	$dbh = DBI->connect(@db_connect_args) or die DBI->errstr;

	prepare_sql(\$dbh, \%sths, 'portdata_findslaves');

	foreach (@ports) {
		if (/^(.*)\/(.*)$/) {
			print "findslaves -> $2/$1\n"
				if ($settings{debug});
			$sths{portdata_findslaves}->execute($2, $1);
			while (my $port = $sths{portdata_findslaves}->fetchrow_hashref) {
				push @ports, "$port->{cat}/$port->{name}"
					unless (arrexists(\@ports, "$port->{cat}/$port->{name}"));
			}
		}
	}

	finish_sql(\$dbh, \%sths);
	$dbh->disconnect;

	# Build any ports we found

	print "\nBuilding updated or new ports...\n";

	$num_ports = $#ports + 1;

	BuildPortsDB(\@ports);

	# Remove files *afterwards*, in case of failure

	foreach (@files) {
		if ($settings{cache_sup_data}) {
			rename $settings{sup_data_dir}."/$_",
			       $settings{sup_data_dir}."/_$_";
		} else {
			unlink $settings{sup_data_dir}."/$_";
		}
	}

	return 1;
}


#------------------------------------------------------------------------------
# Func: CheckPortsDB()
# Desc: Using the information found from a run of BuildPortsDB($), attempt to
#       identify ports with possible updated distfiles.
#
# Args: n/a
#
# Retn: $success				- true/false
#------------------------------------------------------------------------------

sub CheckPortsDB
{
	my ($dbh, $sth);

	$dbh = DBI->connect(@db_connect_args) or die DBI->errstr;

	$sth = $dbh->prepare($sql{portdata_select}) or die DBI->errstr;

	if ($settings{cache_ms_data}) {
		mkdir $settings{ms_data_dir}
			if (! -d $settings{ms_data_dir});
	} else {
		emptydir($settings{ms_data_dir});
	}

	STDOUT->autoflush(1);

	$sth->execute(lc hostname());

	my @workblock;

	my $i = 0;
	my $num_rows = $sth->rows;

	while (my $port = $sth->fetchrow_hashref)
	{
		my $want = 0;

		$i++;

		$want = checkrestricted($port->{name}, $port->{cat}, $port->{maintainer});

		push @workblock, $port if ($port and $want);

		next if (!$want and $i < $num_rows);

		# Got enough work?
		if ($#workblock > $settings{workqueue_size} or $i == $num_rows)
		{
			my $pid = fork;

			die "Cannot fork: $!" unless (defined $pid);

			if ($pid) {
				# Parent
				my $progress = $num_rows - $i;
				print "Spawned PID #$$ ($progress ports unallocated)\n";
				undef @workblock;
			} else {
				# Child

				my (%sths, $dbh, $time);

				$time = time;

				$dbh = DBI->connect(@db_connect_args) or die DBI->errstr;

				prepare_sql(\$dbh, \%sths, qw(portdata_setchecked portdata_setnewver
				                              sitedata_select sitedata_failure
				                              sitedata_success sitedata_initliecount
				                              sitedata_decliecount));

				while (my $port = pop @workblock) {
					VersionCheck(\$dbh, \%sths, \%$port);
				}

				finish_sql(\$dbh, \%sths);
				$dbh->disconnect;

				$time = (time - $time);
				print "PID #$$ finished work block (took $time seconds)\n";

				exit;
			}

			(1) while (waitpid(-1, WNOHANG) > 0);
		}
	}

	(1) while (wait != -1);

	if ($sth->rows == 0) {
		print "No rows found in database query.\n"
	} else {
		print "Master process finished. All work has been distributed.\n";
	}

	$sth->finish;
	$dbh->disconnect;

	return 1;
}


#------------------------------------------------------------------------------
# Func: UncheckPortsDB()
# Desc: Reset all newver, status, and checked fields in database - equivalent
#       to doing a fresh build.
#
# Args: n/a
#
# Retn: n/a
#------------------------------------------------------------------------------

sub UncheckPortsDB
{
	my ($dbh, $sth);

	$dbh = DBI->connect(@db_connect_args) or die DBI->errstr;

	$sth = $dbh->prepare($sql{portdata_uncheck}) or die DBI->errstr;

	print "Resetting 'check' data...\n";

	$sth->execute;

	$sth->finish;
	$dbh->disconnect;
}


#------------------------------------------------------------------------------
# Func: VersionCheck()
# Desc: Check for an updated version of one particular port.
#
# Args: \$dbh 				- Database handle
#       \%sths				- Prepared database statements
#       \$port				- Port data extracted from database
#
# Retn: n/a
#------------------------------------------------------------------------------

sub VersionCheck
{
	my ($dbh, $sths, $port) = @_;

	my ($k, $i);

	$k = $port->{name};
	$i = 0;

	return if (!$port->{distfiles} || !$port->{mastersites});

	info($k, 'VersionCheck()');

	# Loop through master sites
	$sths->{sitedata_select}->execute($port->{mastersites});

	while (my $sitedata = $sths->{sitedata_select}->fetchrow_hashref)
	{
		my $site;

		$site = (grep /\Q$sitedata->{host}\E/, (split ' ', $port->{mastersites}))[0]
			or next;

		my (@files, @dates);

		my $old_found = 0;
		my $new_found = 0;

		last if ($i >= $settings{mastersite_limit});

		$i++;

		info($k, 'Checking site: ' . strchop($site, 60));

		if ($site =~ /^ftp:\/\/([^\/]+)(\/.*)?/)
		{
			my $ftp;
			my $ftpport;
			my ($host, $dir) = ($1, $2);

			$dir = '/' unless ($dir);

			($host, $ftpport) = ($1, $2) if ($host =~ /^(.*):(\d{1,5})$/);

			next unless (length $host > 1);

			# MASTER_SITE_SUBDIR is sometimes empty?
			$dir =~ s/\/+$/\//;

			$ftp = Net::FTP->new(
				$host,
				Port    => $ftpport,
				Timeout => $settings{ftp_timeout},
				Debug   => $settings{debug},
				Passive => $settings{ftp_passive}
			);

			if (!$ftp) {
				info($k, $site, 'FTP connect problem: ' . $@);
				$sths->{sitedata_failure}->execute(lc $host)
				    unless ($settings{precious_data});
				next;
			}

			my $ftp_failures = 0;
			while ($ftp_failures <= $settings{ftp_retries}) {
				if (!$ftp->login('anonymous')) {
					info($k, $site, 'FTP login error: ' . $ftp->message);

					if ($ftp_failures == 0) {
						$sths->{sitedata_failure}->execute(lc $host)
						    unless ($settings{precious_data});
					}

					$ftp_failures++;

					if ($ftp->message =~ /\b(?:IP|connections|too many|connected)\b/i) {
						my $rest = 2+(int rand 15);
						info($k, $site, "Retrying FTP site in $rest seconds " .
						                "(attempt $ftp_failures of "          .
						                "$settings{ftp_retries})");
						sleep $rest;
						next;
					} else {
						last;
					}
				}

				$ftp_failures = 0;
				last;
			}

			next if ($ftp_failures);

			if (!$ftp->cwd($dir)) {
				$ftp->quit;
				info($k, $site, 'FTP cwd error: ' . $ftp->message);
				$sths->{sitedata_failure}->execute(lc $host)
				    unless ($settings{precious_data});
				next;
			}

			@files = $ftp->ls;

			if (!@files) {
				info($k, $site, 'FTP ls error (or no files found): ' . $ftp->message);
				$ftp->quit;
				next;
			}

			$ftp->quit;
		}
		else
		{
			my ($ms_file, $site_error);

			$site_error = 0;

			unless (robotsallowed($dbh, $site, $sitedata)) {
				info($k, $site, 'Ignoring site as per rules in robots.txt.');

				# Don't count 'robots' bans as a failure.
				# (We fetch them from the database so that
				# they can be re-checked every so often.)
				$i--;

				next;
			}

			# Generate a temporary file to put the page content in
			# The file could potentially be used again (not likely
			# really, though...)

			$ms_file = $site;
			$ms_file =~ s/^\.+//;
			$ms_file =~ s/[^A-Za-z0-9\-\_\.]/_/g;
			$ms_file = '_mastersite_' . $k . $ms_file;

			$ms_file = substr($ms_file, 0, MAX_PATH - length($settings{ms_data_dir}) - 1);

			$ms_file = $settings{ms_data_dir} . '/' . $ms_file;

			if (! -f $ms_file)
			{
				my ($ua, $response);

				$ua = LWP::UserAgent->new;
				$ua->agent(USER_AGENT);
				$ua->timeout($settings{http_timeout});

				$response = $ua->get($site, ':content_file' => $ms_file);

				# A 404 here ought to imply that the distfile
				# is unavailable, since we expect it to be
				# inside this directory. However, some sites
				# use scripts or rewrite rules disguised as
				# directories.

				$site_error = 1 if (!$response->is_success);
			}

			unless ($site_error) {
				extractfilenames($ms_file, $port->{sufx}, \@files, \@dates);

				unlink $ms_file unless ($settings{cache_ms_data});
			}

			if (!@files)
			{
				my (%headers, $ua, $response, $url);

				my $bad_mimetypes = 'html|text|css|pdf|jpeg|gif|png|image|mpeg|bitmap';

				$ua = LWP::UserAgent->new;
				$ua->agent(USER_AGENT);
				$ua->timeout(8);

				$url = $site;
				$url .= '/' unless $url =~ /\/$/;

				# We keep a counter of "lies" from each site, and only
				# re-check every so often.

				if ($sitedata->{liecount} > 0) {
					info($k, $site, 'Not doing any guessing; site has previously lied.');
					$sths->{sitedata_decliecount}->execute($sitedata->{host});
					next;
				}

				# Verify site gives an error for bad filenames

				$response = $ua->head($url.randstr(12).".tar.gz");
				%headers  = %{$response->headers};

				# Got a response which wasn't HTTP 4xx -> bail out
				if ($response->is_success && $response->status_line !~ /^4/) {
					info($k, $site, 'Not doing any guessing; site is lieing to us.');
					$sths->{sitedata_initliecount}->execute($sitedata->{host});
					next;
				}

				foreach (verguess($port->{ver}, $port->{limitwhich})) {
					my $guess_v = $_;
					my $old_v   = quotemeta $port->{ver};
					my $s       = quotemeta $port->{sufx};

					# Only change major version if port isn't
					# version-specific

					if ($port->{limitver}) {
						next unless ($guess_v =~ /$port->{limitver}/);
					} elsif ($k =~ /^(.*\D)(\d{1,3})(?:[-_]\D+)?$/) {
						my $nm_nums = $2;
						my $vr_nums = $guess_v;
						my $vo_nums = $old_v;

						unless (($1.$2) =~ /(?:md5|bz2|bzip2|rc4|rc5|ipv6|mp3|utf8)$/i) {
							my $fullver = "";
							while ($vo_nums =~ s/^(\d+?)[-_\.]?//) {
								$fullver .= $1;
								last if ($fullver eq $nm_nums);
							}

							if ($fullver eq $nm_nums) {
								$vr_nums =~ s/[-_\.]//g;
								next unless ($vr_nums =~ /^$nm_nums/);
							}
						}
					}

					info($k, $site, "Guessing version $port->{ver} -> $guess_v");

					foreach (split ' ', $port->{distfiles})
					{
						my ($d) = $_;

						# XXX: No provision for ports that put version in MASTER_SITE

						next unless ($d =~ s/$old_v/$guess_v/gi);

						my $response = $ua->head($url.$d);
						my %headers  = %{$response->headers};

						if ($response->is_success && $response->status_line =~ /^2/ &&
						    $headers{'content-type'} !~ /($bad_mimetypes)/i) {
							info($k, $site, "UPDATE $port->{ver} -> $guess_v");
							$sths->{portdata_setnewver}->execute($guess_v, METHOD_GUESS, $url.$d,
							                                     $port->{id}, $port->{id})
							    unless ($settings{precious_data});
							$new_found = 1;
							last;
						} else {
							info($k, $site, "Guess failed $port->{ver} -> $guess_v");
						}

						last if ($new_found);
					}

					last if ($new_found);
				}
			}

			last if ($new_found);
		}

		# Make note of working site
		$sths->{sitedata_success}->execute(lc $1) if ($site =~ /^(?:ftp|https?):\/\/([^\/]+)/i);

		next if (!@files);

		# Look for a file with a greater version number.
		# Try to find the newest file if there are multiple
		# updates.

		my $poss_match;
		my $poss_url;

		foreach my $f_file (@files)
		{
			foreach (split ' ', $port->{distfiles})
			{
				my ($d) = $_;
				my ($v) = $port->{ver};
				my ($s) = $port->{sufx};

				my $old_v = $v;

				my $skip = 0;

				# Skip beta versions if requested

				if ($port->{skipbeta}) {
					if ($f_file =~ /$beta_regex/i && $d !~ /$beta_regex/i) {
						next;
					}
				}

				# Weed out some bad matches

				if ($settings{freebsdhacks_enable}) {
					foreach (@bad_versions) {
						if ($f_file =~ /$_/i && $d !~ /$_/i) {
								$skip = 1;
							last;
						}
					}
				}

				next if ($skip);

				# XXX: we only need to do this once!

				$v = quotemeta $v;
				$s = quotemeta $s;

				# XXX Force number at start - is this reasonable?
				# XXX: multiple occurences of $v in distfile?

				next unless ($d =~ s/^(.*?)$v(.*)$/\Q$1\E(\\d.*?)\Q$2\E/);

				# Possible candidate - extract version

				if ($f_file =~ /^($d)$/ && $2)
				{
					my $version = $2;
					my $new_v = lc $version;

					# Catch a few missed cases

					$new_v =~ s/(?:$ext_regex)$//;

					# Version is much longer than original - skip it

					next if (length $new_v > (12 + length $old_v));

					# New version is in date format (or contains a date-like
					# string) - old one is not. Probably best to ignore.

					next if ($new_v =~ /$date_regex/i &&
					         $old_v !~ /$date_regex/i);

					# Skip a few strange version format change cases
					# (formatted -> "just a number")

					next if ($new_v !~ /\./ && $old_v =~ /\./);

					# Skip any specific versions if requested

					if ($port->{skipversions}) {
						my $skip = 0;

						foreach (split (/\s+/, $port->{skipversions})) {
							if ($new_v eq $_) {
								$skip = 1;
								last;
							}
						}

						next if ($skip);
					}

					# Only allow new major version if port isn't
					# version-specific

					if ($port->{limitver}) {
						next unless ($new_v =~ /$port->{limitver}/);
					} elsif ($k =~ /^(.*\D)(\d{1,3})(?:[-_]\D+)?$/) {
						my $nm_nums = $2;
						my $vr_nums = $new_v;
						my $vo_nums = $old_v;

						unless (($1.$2) =~ /(?:md5|bz2|bzip2|rc4|rc5|ipv6|mp3|utf8)$/i) {
							my $fullver = '';
							while ($vo_nums =~ s/^(\d+?)[-_\.]?//) {
								$fullver .= $1;
								last if ($fullver eq $nm_nums);
							}

							if ($fullver eq $nm_nums) {
								$vr_nums =~ s/[-_\.]//g;
								next unless ($vr_nums =~ /^$nm_nums/);
							}
						}
					}

					if (defined $port->{limiteven} and $port->{limitwhich} >= 0) {
						next unless checkevenodd($new_v, $port->{limiteven},
						                         $port->{limitwhich});
					}

					# Attempt to stop false positives on versions that
					# look newer - e.g. 2.5 is newer than 2.5-prerelease3
					# Note that this will cause the file to trigger $old_found

					$new_v =~ s/^(.*)-(?:$beta_regex).*$/$1/gi
						or $new_v =~ s/^(.*)(?<=\d)(?:$beta_regex).*$/$1/gi;

					# Test our new version string

					if ($new_v eq $old_v)
					{
						$old_found = 1;
					}
					elsif (my $res = vercompare($new_v, $old_v))
					{
						$new_found = 1;

						# Keep going until we find the newest version
						if (!defined($poss_match) or vercompare($version, $poss_match)) {
							$poss_match = $version;

							$poss_url   = $site;
							$poss_url  .= '/' unless ($poss_url =~ /\/$/);
							$poss_url  .= $f_file;

							next;
						}
					}
				}

#				last if ($new_found);
			}


#			last if ($new_found);
		}

		if ($poss_match) {
			info($k, $site, "UPDATE $port->{ver} -> $poss_match");
			$sths->{portdata_setnewver}->execute($poss_match, METHOD_LIST, $poss_url, $port->{id}, $port->{id})
			    unless ($settings{precious_data});
		}

		last if ($old_found);
	}

	# Update checked timestamp
	$sths->{portdata_setchecked}->execute($port->{id}, $port->{id})
	    unless ($settings{precious_data});

	info($k, 'Done');
}


#------------------------------------------------------------------------------
# Func: robotsallowed()
# Desc: Determine if a given site blocks robots (or us, specifically).
#
# Args: $dbh 		- Database handle, connected.
#       $url 		- URL we intend to fetch.
#       $site		- Relevant record (hash ref.) from sitedata table.
#
# Retn: $allowed	- Are we permitted to spider site?
#------------------------------------------------------------------------------

sub robotsallowed
{
	my ($dbh, $url, $site) = @_;

	my (@paths, $allowed, $sitepath, $pathmatch);

	# Checks enabled?
	if (!$settings{robots_enable}) {
		return 1;
	}

	# Do our records need updating?
	if ($site->{robots_outofdate} || $site->{robots} == ROBOTS_UNKNOWN) {
		my ($ua, $response);

		print STDERR "(Robots) Processing robots.txt for $site->{host}\n"
			if ($settings{debug});

		$ua = LWP::UserAgent->new;
		$ua->agent(USER_AGENT);
		$ua->timeout($settings{http_timeout});

		$response = $ua->get('http://' . $site->{host} . '/robots.txt');

		if ($response->is_success) {
			if ($response->status_line =~ /^4/) {
				# HTTP 404 = no blocks. We can roam free.
				$allowed = ROBOTS_ALLOW;

				print STDERR "(Robots) No robots.txt for $site->{host}\n"
					if ($settings{debug});
			} else {
				# Process rules
				my ($data, $agentmatch);

				$allowed = ROBOTS_ALLOW;

				$data = $response->content;
				$data =~ s/
//g;

				foreach (split /\n+/, $data) {
					my $rule = $_;
					$rule =~ s/^\s*//;
					$rule =~ s/#.*$//;
					$rule =~ s/\s*$//;

					if ($rule =~ s/^User-Agent:\s*//i) {
						my $agent_regex;

						# Build a regex from the wildcard
						# expression. Ignores the possibility
						# of escaped astrisks.
						$agent_regex = '^.*';
						foreach (split /(\*)/, $rule) {
							if ($_ eq '*') {
								$agent_regex .= '.*';
							} else {
								$agent_regex .= quotemeta $_
									unless $_ eq '';
							}
						}
						$agent_regex .= '.*$';

						if (USER_AGENT =~ /$agent_regex/i) {
							my $app_regex = '.*' . quotemeta(APPNAME) . '.*';

							if ($rule =~ /$app_regex/i) {
								$allowed = ROBOTS_SPECIFIC;
							} elsif ($allowed != ROBOTS_SPECIFIC) {
								$allowed = ROBOTS_BLANKET;
							}

							$agentmatch = 1;
						} else {
							$agentmatch = 0;
						}

						print STDERR "(Robots) Rule found for $site->{host} -> $rule "
						             . "(matched: $agentmatch; type: $allowed)\n"
							if ($settings{debug});

						next;
					}

					if ($rule =~ /^(?:Allow|Disallow):/ && !defined $agentmatch) {
						# No User-Agent was specified, so
						# assume '*' is implied.
						$allowed = ROBOTS_BLANKET;
						$agentmatch = 1;
					}

					if ($agentmatch && $rule =~ s/^Disallow:\s*//i) {
						$rule = '/' if ($rule eq '');
						push @paths, $rule;
					}
				}
			}
		} else {
			# Couldn't access server for some reason.
			# Assume we're allowed for now, but it's
			# probable that the site will fail later
			# on anyway.
			return 1;
		}

		if (!$settings{precious_data}) {
			my %sths;
			prepare_sql($dbh, \%sths, 'sitedata_setrobots');
			$sths{sitedata_setrobots}->execute($allowed, join("\n", @paths), $site->{host});
			finish_sql($dbh, \%sths);
		}
	} else {
		$allowed = $site->{robots};
		@paths = split(/\n+/, $site->{robots_paths});
	}

	# See if we're trying to access a banned path.

	$sitepath = $url;
	$sitepath =~ s/^[A-Z0-9]+:\/\///i;
	$sitepath =~ s/^[^\/]*//;

	$pathmatch = 0;

	foreach (@paths) {
		my $pathstart = substr($sitepath, 0, length $_);
		if ($pathstart eq $_) {
			$pathmatch = 1;
			print STDERR "(Robots) Path matched for $site->{host} ($_)\n"
				if ($settings{debug});
			last;
		}
	}

	return 1 if !$pathmatch;

	if ($settings{robots_checking} eq 'strict') {
		# Explicit 'allow' only
		return ($allowed == ROBOTS_ALLOW);
	} else {
		# Ignore blanket bans
		return ($allowed != ROBOTS_SPECIFIC);
	}
}


#------------------------------------------------------------------------------
# Func: GenerateHTML()
# Desc: Build web pages based on database data.
#
# Args: n/a
#
# Retn: $success				- true/false
#------------------------------------------------------------------------------

sub GenerateHTML
{
	my (%sths, %outdata, @time, $dbh, $sth, $template);

	$dbh = DBI->connect(@db_connect_args) or die DBI->errstr;

	prepare_sql(\$dbh, \%sths, qw(portdata_genresults portdata_selectall
	            portdata_selectall_limited));

	print "Organising results...\n";
	$sths{portdata_genresults}->execute;

	emptydir($settings{html_data_dir});

	# Put together some output data for the templates

	@time = ($settings{local_timezone} eq 'GMT') ? gmtime : localtime;
	$outdata{date} = sprintf('%d-%02d-%02d', $time[5]+1900, ++$time[4], $time[3]);
	$outdata{time} = sprintf('%02d:%02d', $time[2], $time[1]);
	$outdata{appname} = APPNAME;
	$outdata{appver}  = APPVER;
	$outdata{author}  = AUTHOR;

	$template = Portscout::Template->new('index.html')
		or die "index.html template not found!\n";

	# Produce indices, sorted by each header

	foreach my $sortby ('withnewdistfile', 'maintainer', 'total', 'percentage')
	{
		my ($sth, $orderby);

		$orderby = ($sortby eq 'maintainer') ? 'ASC' : 'DESC';

		$template->applyglobal(\%outdata);

		print "Generating index sorted by $sortby...\n";
		$sth = $dbh->prepare("SELECT * FROM results ORDER BY $sortby $orderby")
			or die DBI->errstr;
		$sth->execute;

		while (my $row = $sth->fetchrow_hashref) {
			$row->{percentage} = sprintf('%.2f%', $row->{percentage})
				if ($row->{percentage});
			$template->pushrow($row);
		}

		$sth->finish;

		$template->output("index-$sortby.html");
		$template->reset;
	}

	# Point index.html at the default sorted index

	symlink("index-$settings{default_html_sort}.html",
	        "$settings{html_data_dir}/index.html");

	$template = undef;

	# Produce maintainer pages

	print "Creating maintainer pages...\n";

	$template = Portscout::Template->new('maintainer.html')
		or die "maintainer.html template not found!\n";

	$sth = $dbh->prepare('SELECT DISTINCT maintainer FROM results')
		or die DBI->errstr;
	$sth->execute;

	while (my ($addr) = $sth->fetchrow_array)
	{
		$outdata{maintainer} = $addr;
		$template->applyglobal(\%outdata);

		$sths{portdata_selectall}->execute($addr);
		while (my $row = $sths{portdata_selectall}->fetchrow_hashref) {
			if ($row->{ignore}) {
				$row->{method} = 'X';
				$row->{newver} = '';
				$row->{newurl} = '';
			} else {
				if ($row->{method} == METHOD_LIST) {
					$row->{method} = 'L';
				} elsif ($row->{method} == METHOD_GUESS) {
					$row->{method} = 'G';
				} else {
					$row->{method} = '';
				}
			}

			if ($row->{newver} && ($row->{ver} ne $row->{newver})) {
				$row->{newdistfile} = 'updated';
			} else {
				$row->{newdistfile} = '';
			}
			$row->{updated} =~ s/:\d\d\.\d+$/ $settings{local_timezone}/;
			$row->{checked} =~ s/:\d\d\.\d+$/ $settings{local_timezone}/;

			$template->pushrow($row);
		}
		$template->output("$outdata{maintainer}.html");
		$template->reset;

		# We don't want this polluting the data
		# when the next template uses it.
		delete $outdata{maintainer};
	}

	$template = undef;

	print "Creating restricted ports (portconfig) page...\n";

	$template = Portscout::Template->new('restricted-ports.html')
		or die "restricted-ports.html template not found!\n";

	$sths{portdata_selectall_limited}->execute;
	$template->applyglobal(\%outdata);

	while (my $row = $sths{portdata_selectall_limited}->fetchrow_hashref) {
		$row->{limiteven}      = $row->{limiteven}  ? 'EVEN' : 'ODD';
		$row->{limitevenwhich} = $row->{limitwhich} ? ($row->{limitwhich}.':'.$row->{limiteven}) : '';

		$template->pushrow($row);
	}

	$template->output('restricted-ports.html');

	finish_sql(\$dbh, \%sths);
	$dbh->disconnect;
}


#------------------------------------------------------------------------------
# Func: ParseConfigFile()
# Desc: Search for and parse specified configuration file
#
# Args: $file    		- Name of config file
#       \@paths  		- List of paths to search for config file
#       \%varlist		- Where to put configuration options. Possibly
#                		  populated with default values.
#
# Retn: $success 		- true/false (false = BAD file, not missing file)
#------------------------------------------------------------------------------

sub ParseConfigFile
{
	my ($file, $paths, $varlist) = @_;

	my $filename;
	my $lineno;

	while ($_ = shift @$paths) {
		if ( -f $_.'/'.$file ) {
			$filename = $_.'/'.$file;
			last;
		}
	}

	# Return true: we can fall back to defaults
	return 1 unless ($filename);

	$lineno = 0;

	open my $cf, "<$filename" or die "Can't open config file";

	while (my $line = <$cf>)
	{
		my ($var, $val, $quoted);

		$lineno++;

		# Remove comments
		$line =~ s/#.*$//;

		# Skip empty lines
		next unless ($line);

		if ($line =~ /^\s*(.*?)\s*=\s*(.*?)\s*$/) {
			($var, $val) = ($1, $2);
		} else {
			next;
		}

		$var =~ s/\s+/_/g;

		if ($val =~ s/^(["'])//) {
			$val =~ s/$1$//;
			$quoted = 1;
		}

		$var = lc $var;

		if ($var !~ /^[a-z\_]+$/) {
			print STDERR "Invalid variable name found in config file $filename, line $lineno\n";
			return 0;
		}

		# Substitute special values

		if (!$quoted) {
			$val = 1 if (lc $val eq 'true');
			$val = 0 if (lc $val eq 'false');
		}

		(1) while ($val =~ s/%\((.*?)\)/$$varlist{$1}/g);

		$$varlist{$var} = $val;
	}

	close $cf;

	return 1;
}


#------------------------------------------------------------------------------
# Func: makevar()
# Desc: Ask make(1) to expand and return values for specified variables
#
# Args: $dir     			- Directory to execute make in.
#       @vars    			- List of variables.
#
# Retn: [results]			- Ref. to hash of results - unless there was only
#                			  one variable, in which case return a string.
#------------------------------------------------------------------------------

sub makevar
{
	my ($dir, @vars) = @_;

	my (%results, @outp, $list, $cache);

	$cache = $make_cache ? $make_cache : '';

	$list = join(' -V ', @vars);
	@outp = split /\n/, qx(cd $dir && make -V $list $cache 2>/dev/null);

	if ($#vars == 0) {
		return $outp[0];
	}

	foreach (@vars) {
		$results{$_} = shift @outp;
	}

	return \%results;
}


#------------------------------------------------------------------------------
# Func: strchop()
# Desc: Chop or pad string to $limit characters, using ellipses to contract.
#
# Args: $str  			- String to manipulate.
#       $limit			- Length of new string.
#
# Retn:       			- Modified string.
#------------------------------------------------------------------------------

sub strchop
{
	my ($str, $limit) = @_;

	my $slen = int ($limit / 2) - 3;
	my $elen = ($limit - 3) - $slen;

	return "" if (!$str or !$limit);

	if (length $str > $limit)
	{
		return $str if ($str =~ s/^(.{$slen}).*(.{$elen})$/$1...$2/);
	}
	elsif (length $str < $limit)
	{
		return $str if $str .= " " x ($limit - length $str);
	}

	return $str;
}


#------------------------------------------------------------------------------
# Func: emptydir()
# Desc: Remove all files from a given directory, or create an empty directory
#       if it doesn't already exist.
#
# Args: $dir     			- Directory to clear
#
# Retn: $success 			- true/false
#------------------------------------------------------------------------------

sub emptydir
{
	my ($dir) = @_;

	return 0 if (!$dir);

	if (-d $dir) {
		opendir my $dh, $dir;
		unlink "$dir/$_" foreach readdir($dh);
		closedir $dh;
	} else {
		mkdir $dir;
	}

	return 1;
}


#------------------------------------------------------------------------------
# Func: verguess()
# Desc: Guess possible "next version" values from given string.
#       For example: 1.4.2 -> (2.0.0, 1.5.0, 1.4.3)
#
# Args: $ver        	- Current version string
#       $evenoddpart	- Incremement nth component by TWO to keep even/odd
#
# Retn: @ver        	- Array of possible new versions
#------------------------------------------------------------------------------

sub verguess
{
	my ($ver, $evenoddpart) = @_;
	my @ver_guesses;

	return if (!$ver);

	my @vparts = split /(\D+)/, $ver;

	my $i = 0;
	for (0 .. $#vparts) {
		my $guess;

		my $v = $vparts[$i];

		if ($v =~ /^\d+$/) {
			if (defined $evenoddpart and $evenoddpart == $i/2) {
				$v+=2;
			} else {
				$v++;
			}
		} else {
			$i++;
			next;
		}

		$guess .= $vparts[$_] for (0 .. ($i - 1));
		$guess .= $v;

		for (++$i .. $#vparts) {
			if ($vparts[$_] =~ /^\d+$/) {
				$guess .= "0" x length $vparts[$_];
			} elsif ($vparts[$_] =~ /^-?[A-Z]+-?$/i) {
				last;
			} else {
				$guess .= $vparts[$_];
			}
		}

		push @ver_guesses, $guess;
	}

	return @ver_guesses;
}


#------------------------------------------------------------------------------
# Func: vercompare()
# Desc: Compare two version strings and return true if $new is greater than
#       $old; otherwise return false.
#
# Args: $ver   			- New version string
#       $old   			- Old version string
#
# Retn: $result			- Is $new greater than $old? Returns -1 for "Maybe"
#------------------------------------------------------------------------------

sub vercompare
{
	my ($new, $old) = @_;

	my $newletter = 0;

	if ($settings{version_compare} eq 'pkg_version') {
		my $res;

		$new = quotemeta $new;
		$old = quotemeta $old;

		$res = qx(pkg_version -t "$new" "$old");

		return (($res eq ">") ? 1 : 0);
	}

	# If both version strings contain a date AND other
	# numbers, take care to split them and compare
	# individually.

	unless ($new =~ /^$date_regex$/i && $old =~ /^$date_regex$/i)
	{
		my $date_regex = $date_regex;
		$date_regex =~ s/\\1/\\3/g;		# Bump internal backreference (evil)

		if ($new =~ /^(.*?)[\-\.]?($date_regex)[\-\.]?(.*)$/i) {
			my ($new_1, $new_2, $new_3) = ($1, $2, $4);

			if ($old =~ /^(.*?)[\-\.]?($date_regex)[\-\.]?(.*)$/i) {
				my ($old_1, $old_2, $old_3) = ($1, $2, $4);

				if ($new_1 and $old_1) {
					return vercompare($new_1, $old_1) unless ($new_1 eq $old_1);
				}

				if ($new_2 and $old_2) {
					return vercompare($new_2, $old_2) unless ($new_2 eq $old_2);
				}

				if ($new_3 and $old_3) {
					return vercompare($new_3, $old_3) unless ($new_3 eq $old_3);
				} elsif ($new_3) {
					return 1;
				} else {
					return 0;
				}
			}
		}
	}

	# Interpret single letters as a version
	# indicator if possible
	if ($new =~ /^(.*)(?<![A-Z])([A-Z])(?![A-Z])/i) {
		my $let = $2;
		my $pos = length $1;
		if (substr($old, $pos, 1) =~ /([A-Z])/i) {
			$newletter = (lc $let gt lc $1);

			if (lc $let ne lc $1) {
				$new = substr $new, 0, $pos;
				$old = substr $old, 0, $pos;
			}
		} else {
			$newletter = 1;
		}
	}

	my @nums_new = split /\D+/, $new;
	my @nums_old = split /\D+/, $old;

	foreach (0 .. $#nums_new) {
		# New version component; all preceding
		# components are equal, so assume newer.
		return 1 if (!defined($nums_old[$_]));

		# Attempt to handle cases where version
		# component lengths vary.
		if (($_ == $#nums_new) && (length $nums_new[$_] != length $nums_old[$_]))
		{
			my $lendiff_threshold;

			$lendiff_threshold = ($nums_new[$_] =~ /^0/ && $nums_old[$_] =~ /^0/)
			                     ? 1
			                     : 2;

			$nums_new[$_] = $nums_new[$_] . ("0" x length $1) if ($nums_old[$_] =~ /^(0+)/);
			$nums_old[$_] = $nums_old[$_] . ("0" x length $1) if ($nums_new[$_] =~ /^(0+)/);

			# Borderline case - let caller try to find better
			# match before committing.
			# return -1 if (length $nums_new[$_] != length $nums_old[$_]);

			# Experimental code to catch (some) "backwards" version numbers

			my ($lendiff, $first_old, $first_new);

			$lendiff   = length($nums_new[$_]) - length($nums_old[$_]);
			$first_new = substr($nums_new[$_], 0, 1);
			$first_old = substr($nums_old[$_], 0, 1);

			if ($lendiff >= $lendiff_threshold) {
				if ($first_new > $first_old) {
					return -1;
				} elsif ($first_new == $first_old) {
					$nums_old[$_] .= ("0" x $lendiff);
					return ($nums_new[$_] > $nums_old[$_]) ? -1 : 0;
				} else {
					return 0;
				}
			} elsif ($lendiff <= -$lendiff_threshold) {
				if ($first_new < $first_old) {
					return 0;
				} elsif ($first_new == $first_old) {
					$nums_new[$_] .= ("0" x abs $lendiff);
					return ($nums_new[$_] < $nums_old[$_]) ? 0 : -1;
				} else {
					return -1;
				}
			}
		}

		# Otherwise, compare values numerically
		return 1 if (0+$nums_new[$_] > 0+$nums_old[$_]);
		return 0 if (0+$nums_new[$_] < 0+$nums_old[$_]);
	}

	return ($newletter);
}


#------------------------------------------------------------------------------
# Func: checkevenodd()
# Desc: Check that a version component is either even or odd.
#
# Args: $version  		- Version string to check
#       $evenodd  		- True = force even; false = force false
#       $component		- Zero-based component number to check
#
# Retn: $result   		- true/false
#------------------------------------------------------------------------------

sub checkevenodd
{
	my ($version, $evenodd, $component) = @_;

	my @bits = split /\D+/, $version;

	return 0 if $#bits < $component;

	if ($bits[$component] % 2) {
		return !$evenodd;
	} else {
		return $evenodd;
	}
}


#------------------------------------------------------------------------------
# Func: MovePorts()
# Desc: Handle any ports which have been moved.
#
# Args: $addonly		- Should we just record the entries, or start moving
#               		  ports around? (true = the former)
#
# Retn: $success		- true/false
#------------------------------------------------------------------------------

sub MovePorts
{
	my ($addonly) = @_;

	my (%sths, $dbh);

	my $error = 0;

	my $moved_file = $settings{ports_dir}.'/MOVED';

	print "Processing MOVED entries...\n";

	return 0 unless (-f $moved_file);

	$dbh = DBI->connect(@db_connect_args) or die DBI->errstr;

	prepare_sql(\$dbh, \%sths, qw(moveddata_exists portdata_move portdata_setmoved
	            portdata_exists portdata_removestale moveddata_insert));

	open my $mf, "<$moved_file" or $error = 1;

	while (<$mf>)
	{
		my $rows = 0;

		next if /^#/;

		my ($port_from, $port_to, $date, $reason) = split /\|/;

		my ($port_fromcat, $port_fromname, $port_tocat, $port_toname);

		next unless ($port_from);

		$sths{moveddata_exists}->execute($port_from, $port_to, $date);
		$rows = $sths{moveddata_exists}->fetchrow_arrayref->[0];
		next unless ($rows == 0);

		info($port_from, ($port_to ? 'Moving to ' . $port_to
		                           : 'Deleting'));

		if ($addonly) {
			$sths{moveddata_insert}->execute($port_from, $port_to, $date, $reason)
				unless ($settings{precious_data});
			next;
		}

		if ($port_to)
		{
			my ($to_exists, $from_exists);

			($port_fromcat, $port_fromname) = ($1, $2)
				if ($port_from =~ /^(.*)\/(.*)/);

			($port_tocat, $port_toname) = ($1, $2)
				if ($port_to =~ /^(.*)\/(.*)/);

			$sths{portdata_exists}->execute($port_toname, $port_tocat);
			$to_exists = $sths{portdata_exists}->fetchrow_arrayref->[0];

			$sths{portdata_exists}->execute($port_fromname, $port_fromcat);
			$from_exists = $sths{portdata_exists}->fetchrow_arrayref->[0];

			if ($to_exists && $from_exists)
			{
				# Destination and source both exist!
				info($port_from, '--> Source and dest exist - marking as moved.');

				$sths{portdata_setmoved}->execute($port_fromname, $port_fromcat)
					unless ($settings{precious_data});
			}
			elsif ($to_exists && !$from_exists)
			{
				# Port already moved
				info($port_from, '--> Port already moved.');

				$sths{moveddata_insert}->execute($port_from, $port_to, $date, $reason)
					unless ($settings{precious_data});
				next;
			}
			elsif (!$to_exists && $from_exists)
			{
				# Fall through
				info($port_from, '--> Executing.');
			}
			elsif (!$to_exists && !$from_exists)
			{
				# Fall through
				info($port_from, '--> Port already (re)moved.');
			}

			$sths{portdata_move}->execute($port_fromcat, $port_fromname,
			                              $port_tocat, $port_toname)
				unless ($settings{precious_data});
		}
		else
		{
			info($port_from, '--> Executing.');
			$sths{portdata_setmoved}->execute($port_fromname, $port_fromcat)
				unless ($settings{precious_data});
		}

		$sths{moveddata_insert}->execute($port_from, $port_to, $date, $reason)
			unless ($settings{precious_data});
	}

	print "Finalizing pending MOVED terminations...\n";

	$sths{portdata_removestale}->execute
		unless ($settings{precious_data});

	close $mf;

	finish_sql(\$dbh, \%sths);
	$dbh->disconnect;

	return ($error ? 0 : 1);
}


#------------------------------------------------------------------------------
# Func: CheckIndex()
# Desc: Find an index file, and count how many ports are in it
#
# Args: n/a
#
# Retn: $success		- true/false
#------------------------------------------------------------------------------

sub CheckIndex
{
	# Verify index file exists

	$index_file = makevar($settings{ports_dir}, 'INDEXFILE');
	chomp $index_file;

	$index_file = $settings{ports_dir} . "/" . $index_file;

	return 0 unless (-f $index_file);

	# Count ports

	open my $if, "<$index_file";

	if ($if) {
		my $buf;
		$num_ports = 0;
		$num_ports += ($buf =~ tr/\n//) while (sysread $if, $buf, 4096);
		close $if;
	}

	return 1;
}


#------------------------------------------------------------------------------
# Func: InitMakeCache()
# Desc: Prepare a cache of make(1) variables for makevar(). This essentially
#       saves a dozen forks each time make is invoked, saving us precious
#       time while populating the database.
#
# Args: $dir     			- Directory to execute make in.
#       @vars    			- List of variables to cache.
#
# Retn: $success 			- true/false
#------------------------------------------------------------------------------

sub InitMakeCache
{
	my ($dir, @vars) = @_;

	my ($mv, $list);

	$make_cache = '';

	return 0 if (!$dir || !@vars);

	$mv = makevar($dir, @vars);

	if ($#vars == 0) {
		$make_cache = "$vars[0]=$mv";
		return 1;
	}

	$make_cache .= "$_=". ($mv->{$_} || '')
		foreach (keys %$mv);

	return 1;
}


#------------------------------------------------------------------------------
# Func: MailMaintainers()
# Desc: Send a reminder e-mail to interested parties, about their ports.
#
# Args: n/a
#
# Retn: $success		- true/false
#------------------------------------------------------------------------------

sub MailMaintainers
{
	my (%sths, $dbh, $template);

	if (!$settings{mail_enable}) {
		print "Reminder mails are disabled; taking no action.\n";
		return 1;
	}

	print "Mailing maintainers of out-of-date ports...\n\n";

	$dbh = DBI->connect(@db_connect_args) or die DBI->errstr;

	prepare_sql(\$dbh, \%sths, qw(maildata_select portdata_findnewnew
	            portdata_setmailed));

	$sths{maildata_select}->execute;

	$template = Portscout::Template->new('reminder.mail')
		or die "reminder.mail template not found!\n";

	while (my ($addr) = $sths{maildata_select}->fetchrow_array) {
		my $msg;
		my $ports = 0;
		$sths{portdata_findnewnew}->execute($addr);
		$template->applyglobal({maintainer => lc $addr});

		while (my $port = $sths{portdata_findnewnew}->fetchrow_hashref) {
			$port->{cat_portname} = "$port->{cat}/$port->{name}";
			$template->pushrow($port);
			$ports++;
		}

		if ($ports == 0) {
			$template->reset;
			next;
		}

		info($addr, "$ports new port(s) out of date");

		$msg = MIME::Lite->new(
			From     => $settings{mail_from} =~ /@/
			                ? $settings{mail_from}
			                : $settings{mail_from}."@".hostname(),
			To       => $addr,
			Subject  => $settings{mail_subject},
			Data     => $template->string
		);

		$msg->replace('X-Mailer' => USER_AGENT);

		$msg->send;

		$template->reset;

		# Second pass to mark port newvers as mailed

		if (!$settings{precious_data}) {
			$sths{portdata_findnewnew}->finish;
			$sths{portdata_findnewnew}->execute($addr);

			while (my $port = $sths{portdata_findnewnew}->fetchrow_hashref) {
				$sths{portdata_setmailed}->execute($port->{newver}, $port->{name}, $port->{cat});
			}
		}
	}

	finish_sql(\$dbh, \%sths);
	$dbh->disconnect;

	return 1;
}


#------------------------------------------------------------------------------
# Func: AllocatePorts()
# Desc: Divide up the ports database and allocate to machines in the portscout
#       cluster -- if there are any.
#
# Args: n/a
#
# Retn: $success		- true/false
#------------------------------------------------------------------------------

sub AllocatePorts
{
	my (%sths, $dbh, $remaining);

	print "Checking for registered allocators...\n";

	if (!$settings{cluster_enable}) {
		print "Clustering disabled; taking no action.\n";
		return 1;
	}

	$dbh = DBI->connect(@db_connect_args) or die DBI->errstr;

	prepare_sql(\$dbh, \%sths, qw(portdata_countleft portdata_deallocate
	            allocators_count allocators_select));

	$sths{portdata_deallocate}->execute
		unless ($settings{precious_data} or $settings{system_affinity});

	$sths{allocators_count}->execute;
	($remaining) = $sths{allocators_count}->fetchrow_array;

	if ($remaining <= 0) {
		print "Found none (portscout will run on just this machine)\n";
		return 1;
	} else {
		print "Allocating work using $remaining allocator rule(s)...\n";
	}

	for my $pass (0 .. 2)
	{
		print STDERR "Allocator pass $pass/2\n"
			if ($settings{debug});

		$sths{allocators_select}->execute;

		while (my $allocator = $sths{allocators_select}->fetchrow_hashref)
		{
			my ($query, $unallocated, $i);

			$query = q(UPDATE portdata
			              SET systemid = ?
			            WHERE moved != true
			              AND systemid is NULL);

			$sths{portdata_countleft}->execute;
			($unallocated) = $sths{portdata_countleft}->fetchrow_array;

			$i = ceil($unallocated / $remaining);

			print STDERR "--> Allocator loop ($unallocated, $remaining)\n"
				if ($settings{debug});

			if ($allocator->{allocator} eq 'random') {
				next unless ($pass == 2);

				$query .= " AND id IN (SELECT id FROM portdata LIMIT $i)"
					unless ($remaining == 1);

				$dbh->do($query, undef, $allocator->{systemid})
					unless ($settings{precious_data});
			} elsif ($allocator->{allocator} eq 'presplit') {
				next unless ($pass == 1);

				# XXX: Unimplemented
				print STDERR "Unsupported allocator (presplit) found.\n";
			} else {
				# Fixed constraints - allocate first
				next unless ($pass == 0);

				my (%constraints, $sth);

				foreach (split /,/, $allocator->{allocator}) {
					if (/^(maintainer|cat)=(.*)$/i) {
						$constraints{lc $1} = lc $2;
					} else {
						print STDERR "Unexpected constraint or wrong format ($_).\n";
						next;
					}
				}

				$query .= ' AND (1=0';
				$query .= " OR $_ = ?"
					foreach (keys %constraints);
				$query .= ')';

				$dbh->do($query, undef, $allocator->{systemid}, values %constraints)
					unless ($settings{precious_data});
			}

			$remaining--;
		}
	}

	finish_sql(\$dbh, \%sths);
	$dbh->disconnect;

	return 1;
}


#------------------------------------------------------------------------------
# Func: checkrestricted()
# Desc: Check the restriction lists are either empty or contain the specified
#       values.
#
# Args: $port      		- Port name
#       $category  		- Category
#       $maintainer		- Maintainer
#
# Retn: $result    		- true = all values falls within constraints
#------------------------------------------------------------------------------

sub checkrestricted
{
	my ($port, $category, $maintainer) = @_;

	my $skip;

	$skip = 1 if ($settings{restrict_maintainer});
	foreach (split /,/, lc $settings{restrict_maintainer}) {
		s/^\s*(.*)\s*/$1/;
		if ($_ eq lc $maintainer) {
			$skip = 0;
			last;
		}
	}

	return 0 if ($skip);

	$skip = 1 if ($settings{restrict_category});
	foreach (split /,/, lc $settings{restrict_category}) {
		s/^\s*(.*)\s*/$1/;
		if ($_ eq lc $category) {
			$skip = 0;
			last;
		}
	}

	return 0 if ($skip);

	$skip = 1 if ($settings{restrict_port});
	foreach (split /,/, lc $settings{restrict_port}) {
		s/^\s*(.*)\s*/$1/;
		if ($_ eq lc $port or $_ eq lc "$category/$port") {
			return 1;
		}
	}

	return !$skip;
}


#------------------------------------------------------------------------------
# Func: extractfilenames()
# Desc: Extract filenames (and dates, where possible) from a mastersite index
#
# Args: $file   		- Master site data filename
#       $sufx   		- Distfile suffix (e.g. ".tar.gz")
#       \$files 		- Where to put filenames found
#       \$dates 		- Where to put dates found
#
# Retn: $success		- true/false
#------------------------------------------------------------------------------

sub extractfilenames
{
	my ($file, $sufx, $files, $dates) = @_;

	my $got_index = 0;

	$sufx = quotemeta $sufx;

	open my $ms, "<$file" or return 0;

	my $date_regex  = '(?<!\d)(\d{2}(?:\d{2})?([\-\. ]?)(\d{2}|' .
	                  $month_regex . ')\4\d{2}(?:\d{2})?)(?!\d)' .
	                  '(?:\s*(?:(\d{2}):(\d{2}))?)?';

	# XXX: Work-in-Progress
	# XXX: @dates will contain garbage

	while (<$ms>)
	{
		while (/<a href=(['"])(.*?$sufx)\1.*?<\/a>(.*?)/gi)
		{
			push @$files, $2;

			next if ($3 =~ /^\d{4}.{2,}\d{4}$/);
			push @$dates, ($got_index) ? $3 || "" : "";
		}

		$got_index = /<title>\s*index of.*?<\/title>/i if (!$got_index);
	}

	close $ms;

	return 1;
}


#------------------------------------------------------------------------------
# Func: getdbver()
# Desc: Return the current database schema version.
#
# Args: n/a
#
# Retn: $version 		- database version.
#------------------------------------------------------------------------------

sub getdbver
{
	my ($dbh, $sth, $ver);

	$dbh = DBI->connect(@db_connect_args) or die DBI->errstr;

	$sth = $dbh->prepare($sql{portscout_version}) or die DBI->errstr;
	$sth->execute;

	($ver) = $sth->fetchrow_array;

	$sth->finish;
	$dbh->disconnect;

	return $ver;
}


#------------------------------------------------------------------------------
# Func: prepare_sql()
# Desc: Prepare the named SQL statements.
#
# Args: \$dbh    		- Database handle, already connected.
#       \%sths   		- Somewhere to put prepared statement handles
#       @queries 		- Names of queries to prepare -- from %sql hash.
#
# Retn: $success 		- true/false
#------------------------------------------------------------------------------

sub prepare_sql
{
	my ($dbh, $sths, @queries) = @_;

	foreach (@queries) {
		if (exists $sql{$_}) {
			$$sths{$_} = $$dbh->prepare($sql{$_}) or die DBI->errstr;
		} else {
			print STDERR "Attempted to prepare non-existent SQL query ($_).\n";
			return 0;
		}
	}

	return 1;
}


#------------------------------------------------------------------------------
# Func: finish_sql()
# Desc: Finish specified SQL statements.
#
# Args: \$dbh    		- Database handle, already connected.
#       \%sths   		- The hash of prepared statement handles.
#
# Retn: $success 		- true/false
#------------------------------------------------------------------------------

sub finish_sql
{
	my ($dbh, $sths) = @_;

	$$sths{$_}->finish
		foreach (keys %$sths);

	return 1;
}


#------------------------------------------------------------------------------
# Func: info()
# Desc: Format arguments into message and print.
#
# Args: @str			- Array of message parts to chop and format.
#       $msg			- Message to print unformatted after other parts.
#
# Retn: n/a
#------------------------------------------------------------------------------

sub info
{
	my @items = (@_);
	my ($str, $msg);

	return if ($settings{quiet});

	$msg = pop (@items);

	foreach (@items) {
		$str .= ' ' if ($str);
		$str .= '[' . strchop($_, 30) . ']';
	}

	print "$str $msg\n";
}


#------------------------------------------------------------------------------
# Func: randstr()
# Desc: Generate string of random characters
#
# Args: $len			- Length of string to generate.
#
# Retn: $str			- Random string.
#------------------------------------------------------------------------------

sub randstr
{
	my ($len) = @_;

	my @chars = ('a'..'z','A'..'Z','0'..'9');

	my $str;
	$str .= $chars[rand @chars] foreach (1 .. $len);

	return $str;
}


#------------------------------------------------------------------------------
# Func: arrexists()
# Desc: 'exists' for array values.
#
# Args: \@array			- Array to search.
#       $value 			- Value to check for.
#
# Retn: exists 			- Does the value exist?
#------------------------------------------------------------------------------

sub arrexists
{
	my ($array, $value) = (@_);

	foreach (@{$array}) {
		return 1 if ($_ eq $value);
	}

	return 0;
}


#------------------------------------------------------------------------------
# Func: SwitchUser()
# Desc: Drop root privileges, switching to another user (if configured to).
#
# Args: n/a
#
# Retn: n/a
#------------------------------------------------------------------------------

sub SwitchUser
{
	if ($settings{group} && getgid() == 0) {
		my $gid = getgrnam($settings{group})
			or die "Couldn't determine GID from name $settings{group}\n";
		setgid($gid)
			or die "Couldn't switch to group $settings{group}";
	}

	if ($settings{user} && getuid() == 0) {
		my $uid = getpwnam($settings{user})
			or die "Couldn't determine UID from name $settings{user}\n";
		setuid($uid)
			or die "Couldn't switch to user $settings{user}";
	}

	return 1;
}


#------------------------------------------------------------------------------
# Func: Usage()
# Desc: Print usage message and exit.
#
# Args: n/a
#
# Retn: n/a
#------------------------------------------------------------------------------

sub Usage
{
	my $s = basename($0);

	print STDERR "Usage: \n";
	print STDERR "       $s build\n";
	print STDERR "       $s rebuild\n";
	print STDERR "       $s check\n";
	print STDERR "       $s mail\n";
	print STDERR "       $s generate\n";
	exit 1;
}

# ex: ts=4 sw=4
