#!/usr/bin/perl
#
# buildd-mail: mail answer processor for buildd
# Copyright (C) 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; either version 2 of the
# License, or (at your option) any later version.
#
# This program 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 for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#
# $Id$
#

BEGIN {
	($main::HOME = $ENV{'HOME'})
		or die "HOME not defined in environment!\n";
	$main::HOME =~ /^(.*)$/;
	$main::HOME = $1;
	push( @INC, "$main::HOME/lib" );
}

use strict;
use Buildd;
use POSIX;
use File::Basename;

$main::keep_running = 1;
$ENV{'PATH'} = "$main::HOME/bin:/bin:/usr/bin:/usr/local/bin";
read_config();

chdir( "$main::HOME" );

if ($conf::sshsocket and -S "build/$conf::sshsocket") {
	$conf::sshcmd .= " -S build/$conf::sshsocket";
}

chomp( $main::arch = `dpkg --print-installation-architecture` );
$main::arch =~ /^(\S+)/; $main::arch = $1;
$conf::wanna_build_user ||= $Buildd::username;
$conf::log_queued_messages = 1 if !defined $conf::log_queued_messages;

# check if another watcher is still running
relock:
my $mailer_pid;
repeat:
if (!sysopen( F, "mailer-running", O_WRONLY|O_CREAT|O_TRUNC|O_EXCL, 0644 )) {
	if ($! == EEXIST) {
		goto repeat if !open( F, "<mailer-running" );
		my $mailer_pid = <F>;
		close( F );
		if ($mailer_pid !~ /^\s*(\d+)/) {
			# file probably created, but not written yet by another process
			sleep 2;
			goto repeat;
		}
		$mailer_pid = $1;
		if (kill( 0, $mailer_pid ) == 0 && $! == ESRCH) {
			logger( "Ignoring stale mailer-running file (pid $mailer_pid).\n");
			unlink( "mailer-running" );
			goto repeat;
		}
		logger( "Another buildd-mail (pid $mailer_pid) is already running.\n");
		exit 0;
	}
	die "Can't create mailer-running: $!\n";
}
$main::keep_running = 0;
printf F "%5d\n", $$;
close( F );
END { unlink( "mailer-running" ) if !$main::keep_running; }

lock_file( "daemon.log" );
END { unlock_file( "daemon.log" ); }
open_log();

my($error, $short_error, %header, $body_text);
my $mailfile;
while( $mailfile = get_next_file() ) {
	if (!open( MAIL, "<$mailfile" )) {
		logger( "Cannot open $mailfile: $!\n" );
		next;
	}
	process_mail();
	close( MAIL );
	unlink( $mailfile )
		or logger( "Cannot remove $mailfile: $!\n" );
}

$main::keep_running = 1;
unlink( "mailer-running" );

# This check for a mail file again is to plug a race condition that
# could take place if a mail file is created after our last check in
# the loop, but mailer-running is still present and no new buildd-mail
# started. In the other case that a new mail comes in after removing
# mailer-running and before the check and a second buildd-mail is
# started is handled by the mailer-running locking: one of the
# processes will exit.
goto relock if get_next_file();

exit 0;


sub get_next_file {
	my @files = glob( "mqueue/mail.*" );
	return @files ? $files[0] : "";
}

sub process_mail {

my $header_text = "";
my $lastheader = "";
$body_text = "";
undef %header;
$error = $short_error = "";

while( <MAIL> ) {
	$header_text .= $_;
	last if /^$/;
	
	if (/^\s/ && $lastheader) {
		$_ =~ s/^\s+//;
		$_ = "$lastheader $_";
	}
	
	if (/^From (\S+)/) {
		;
	}
	if (/^([\w\d-]+):\s*(.*)\s*$/) {
		my $hname;
		($hname = $1) =~ y/A-Z/a-z/;
		$header{$hname} = $2;
		$lastheader = $_;
		chomp( $lastheader );
	}
	else {
		$lastheader = "";
	}
}
while( <MAIL> ) {
	last if !/^\s*$/;
}
$body_text .= $_;

if (!eof)
	{ local($/); undef $/; $body_text .= <MAIL>; }

if ($header{'from'} =~ /mail\s+delivery\s+(sub)?system|mailer.\s*daemon/i) {
	# is an error mail from a mailer daemon
	# To avoid mail loops if this error resulted from a mail we sent
	# outselves, we break the loop by not forwarding this mail after the 5th
	# error mail within 8 hours or so.
	my $n = add_error_mail();
	if ($n > 5) {
		logger( "Too much error mails ($n) within ",
				int($conf::error_mail_window/(60*60)), " hours\n",
				"Not forwarding mail from $header{'from'}\n",
				"Subject: $header{'subject'}\n" );
		return;
	}
}

goto forward_mail if !$header{'subject'};
my $subject = $header{'subject'};

if ($subject =~ /^Re: Log for \S+ build of (\S+) \(dist=(\S+)\)/i) {
	# reply to a build log
	my( $package, $dist ) = ( $1, $2 );
	$body_text =~ /^(\S+)/;
	my $keyword = $1;
	my $from = $header{'from'};
	$from = $1 if $from =~ /<(.+)>/;
	logger( "Log reply from $from\n" );
	my %newv;

	if ($keyword =~ /^not-for-us/) {
		no_build( $package, $dist );
		purge_pkg( $package, $dist );
	}
	elsif ($keyword =~ /^up(l(oad)?)?-rem/) {
		remove_from_upload( $package );
	}
	elsif (check_is_outdated( $dist, $package )) {
		# $error has been set already -> no action here
	}
	elsif ($keyword =~ /^fail/) {
		my $text = $body_text;
		$text =~ s/^fail.*\n(\s*\n)*//;
		$text =~ s/\n+$/\n/;
		set_to_failed( $package, $dist, $text );
		purge_pkg( $package, $dist );
	}
	elsif ($keyword =~ /^ret/) {
		if (!check_state( $package, $dist, "Building" )) {
			# $error already set
		}
		else {
			append_to_REDO( $package, $dist );
		}
	}
	elsif ($keyword =~ /^d(ep(endency)?)?-(ret|w)/) {
		if (!check_state( $package, $dist, "Building" )) {
			# $error already set
		}
		else {
			$body_text =~ /^\S+\s+(.*)$/m;
			my $deps = $1;
			set_to_depwait( $package, $dist, $deps );
			purge_pkg( $package, $dist );
		}
	}
	elsif ($keyword =~ /^man/) {
		if (!check_state( $package, $dist, "Building" )) {
			# $error already set
		}
		else {
			# no action
			logger( "$package($dist) will be finished manually\n" );
		}
	}
	elsif ($keyword =~ /^newv/) {
		# build a newer version instead
		$body_text =~ /^newv\S*\s+(\S+)/;
		my $newv = $1;
		if ($newv =~ /_/) {
			logger( "Removing unneeded package name from $newv\n" );
			$newv =~ s/^.*_//;
			logger( "Result: $newv\n" );
		}
		my $pkgname;
		($pkgname = $package) =~ s/_.*$//;
		redo_new_version( $dist, $package, "${pkgname}_${newv}" );
		purge_pkg( $package, $dist );
	}
	elsif ($keyword =~ /^(give|back)/) {
		$body_text =~ /^(give|back) ([-0-9]+)/;
		my $pri = $1;
		if (!check_state( $package, $dist, "Building" )) {
			# $error already set
		}
		else {
			give_back( $package, $dist );
			purge_pkg( $package, $dist );
		}
	}
	elsif ($keyword =~ /^purge/) {
		purge_pkg( $package, $dist );
	}
	elsif ($body_text =~ /^---+\s*BEGIN PGP SIGNED MESSAGE/) {
		if (prepare_for_upload( $package, $body_text )) {
			purge_pkg( $package );
		}
	}
	elsif ($body_text =~ /^--/ && $header{'content-type'} =~ m,multipart/signed,) {
		my ($prot)  = ($header{'content-type'} =~ m,protocol="([^"]*)",);
		my ($bound) = ($header{'content-type'} =~ m,boundary="([^"]*)",);
		$body_text =~ s,^--\Q$bound\E\nContent-Type: text/plain; charset=us-ascii\n\n,-----BEGIN PGP SIGNED MESSAGE-----\n\n,;
		$body_text =~ s,--\Q$bound\E\nContent-Type: application/pgp-signature\n\n,,;
		$body_text =~ s,\n\n--\Q$bound\E--\n,,;
		if (prepare_for_upload( $package, $body_text )) {
			purge_pkg( $package, $dist );
		}
	}
	else {
		$short_error .= "Bad keyword in answer $keyword\n";
		$error .= "Answer not understood (expected retry, failed, manual,\n".
				  "dep-wait, giveback, not-for-us, purge, upload-rem,\n".
				  "newvers, or a signed changes file)\n";
	}
}
elsif ($subject =~ /^Re: Should I build (\S+) \(dist=(\S+)\)/i) {
	# reply whether a prev-failed package should be built
	my( $package, $dist ) = ( $1, $2 );
	$body_text =~ /^(\S+)/;
	my $keyword = $1;
	logger( "Should-build reply for $package($dist)\n" );
	if (check_is_outdated( $dist, $package )) {
		# $error has been set already -> no action here
	}
	elsif (!check_state( $package, $dist, "Building" )) {
		# $error already set
	}
	elsif ($keyword =~ /^(build|ok)/) {
		append_to_REDO( $package, $dist );
	}
	elsif ($keyword =~ /^fail/) {
		my $text = get_fail_msg( $package, $dist );
		set_to_failed( $package, $dist, $text );
	}
	elsif ($keyword =~ /^(not|no-b)/) {
		no_build( $package, $dist );
	}
	elsif ($keyword =~ /^(give|back)/) {
		give_back( $package, $dist );
	}
	else {
		$short_error .= "Bad keyword in answer $keyword\n";
		$error .= "Answer not understood (expected build, ok, fail, ".
				  "give-back, or no-build)\n";
	}
}
elsif ($subject =~ /^Processing of (\S+)/) {
	my $job = $1;
	# mail from Erlangen queue daemon: forward all non-success messages
	goto forward_mail if $body_text !~ /uploaded successfully/mi;
	logger( "$job processed by upload queue\n" )
		if $conf::log_queued_messages;
}
elsif ($subject =~ /^([-+~\.\w]+\.changes) (INSTALL|ACCEPT)ED/) {
	# success mail from dinstall
	my $changes_f = $1;
	my( @to_remove, $upload_f, $pkgv );
	my $upload_dir = "$main::HOME/upload";
	$upload_dir .= "-security" if -f "$upload_dir-security/$changes_f";

	if (-f "$upload_dir/$changes_f" && open( F, "<$upload_dir/$changes_f" )) {
		local($/); undef $/;
		my $changetext = <F>;
		close( F );
		push( @to_remove, get_files_from_changes( $changetext ) );
	} else {
		foreach (split( "\n", $body_text )) {
			if (/^(\[-+~\.\w]+\.(u?deb))$/) {
				my $f = $1;
				push( @to_remove, $f ) if !grep { $_ eq $f } @to_remove;
			}
		}
	}
	($upload_f = $changes_f) =~ s/\.changes$/\.upload/;
	push( @to_remove, $changes_f, $upload_f );
	($pkgv = $changes_f) =~ s/_(\S+)\.changes//;
	logger( "$pkgv has been installed; removing from upload dir:\n",
			"@to_remove\n" );

	my @dists;
	if (open( F, "<$upload_dir/$changes_f" )) {
		my $changes_text;
		{ local($/); undef $/; $changes_text = <F>; }
		close( F );
		@dists = get_dists_from_changes( $changes_text );
	} else {
		logger( "Cannot get dists from $upload_dir/$changes_f: $! (assuming unstable)\n" );
		@dists = ( "unstable" );
	}

FILE:	foreach (@to_remove) {
		if (/\.deb$/) {
			# first listed wins
			foreach my $dist (@dists) {
				if ( -d "$main::HOME/build/chroot-$dist" && -w "$main::HOME/build/chroot-$dist/var/cache/apt/archives/") {
					# TODO: send all of to_remove to perl-apt if it's available, setting a try_mv list
					# that only has build-depends in it.
					# if that's too much cpu, have buildd use perl-apt if avail to export the
					# build-depends list, which could then be read in at this point
					if (system "mv $upload_dir/$_ $main::HOME/build/chroot-$dist/var/cache/apt/archives/") {
						logger( "Cannot move $upload_dir/$_ to cache dir\n" );
					} else {
						next FILE;
					}
				}
			}
		}
		unlink "$upload_dir/$_"
			or logger( "Can't remove $upload_dir/$_: $!\n" );
	}
}
elsif ($subject =~ /^(\S+\.changes) is NEW$/) {
	# "is new" mail from dinstall
	my $changes_f = $1;
	my $pkgv;
	($pkgv = $changes_f) =~ s/_(\S+)\.changes//;
	logger( "$pkgv must be manually dinstall-ed -- delayed\n" );
}
elsif ($subject =~ /^new version of (\S+) \(dist=(\S+)\)$/) {
	# notice from from wanna-build
	my ($pkg, $dist) = ($1, $2);
	goto forward if $body_text !~ /^in version (\S+)\.$/m;
	my $pkgv = $pkg."_".$1;
	$body_text =~ /new source version (\S+)\./m;
	my $newv = $1;
	logger( "Build of $pkgv ($dist) obsolete -- new version $newv\n" );
	register_outdated( $dist, $pkgv, $pkg."_".$newv );

	my @ds;
	if (!(@ds = check_building_any_dist( $pkgv ))) {
		if (!remove_from_REDO( $pkgv )) {
			append_to_SKIP( $pkgv );
		}
		purge_pkg( $pkgv, $dist );
	}
	else {
		logger( "Not deleting, still building for @ds\n" );
	}
}
elsif ($body_text =~ /^blacklist (\S+)\n$/) {
	my $pattern = "\Q$1\E";
	if (open( F, ">>mail-blacklist" )) {
		print F "$pattern\n";
		close( F );
		logger( "Added $pattern to blacklist.\n" );
	}
	else {
		logger( "Can't open mail-blacklist for appending: $!\n" );
	}
}
else {
	goto forward_mail;
}

if ($error) {
	logger( "Error: ", $short_error || $error );
	reply( "Your mail could not be processed:\n$error" );
}
return;

forward_mail:
logger( "Mail from $header{'from'}\nSubject: $subject\n" );
if (is_blacklisted( $header{'from'} )) {
	logger( "Address is blacklisted, deleting mail.\n" );
}
else {
	logger( "Not for me, forwarding to admin\n" );
	ll_send_mail( $conf::admin_mail,
				  "To: $header{'to'}\n".
				  ($header{'cc'} ? "Cc: $header{'cc'}\n" : "").
				  "From: $header{'from'}\n".
				  "Subject: $header{'subject'}\n".
				  "Date: $header{'date'}\n".
				  "Message-Id: $header{'message-id'}\n".
				  ($header{'reply-to'} ? "Reply-To: $header{'reply-to'}\n" : "").
				  ($header{'in-reply-to'} ? "In-Reply-To: $header{'in-reply-to'}\n" : "").
				  ($header{'references'} ? "References: $header{'references'}\n" : "").
				  "Resent-From: $Buildd::gecos <$Buildd::username\@$Buildd::hostname>\n".
				  "Resent-To: $conf::admin_mail\n\n".
				  $body_text );
}
}


sub prepare_for_upload {
	my $pkg = shift;
	my $changes = shift;
	my( @files, @md5, @missing, @md5fail, $i );

	my @to_dists = get_dists_from_changes( $changes );
	if (!@to_dists) { # probably not a valid changes
		$short_error = $error;
		$error .= "Couldn't find a valid Distribution: line.\n";
		return 0;
	}
	$changes =~ /^Files:\s*\n((^[ 	]+.*\n)*)/m;
	foreach (split( "\n", $1 )) {
		push( @md5, (split( /\s+/, $_ ))[1] );
		push( @files, (split( /\s+/, $_ ))[5] );
	}
	if (!@files) { # probably not a valid changes
		$short_error = $error;
		$error .= "No files listed in changes.\n";
		return 0;
	}
	my @wrong_dists = ();
	foreach my $d (@to_dists) {
		push( @wrong_dists, $d )
			if !check_state($pkg, $d, qw(Building Install-Wait Reupload-Wait));
	}
	if (@wrong_dists) {
		$short_error = $error;
		$error .= "Package $pkg has target distributions @wrong_dists\n".
				  "for which it isn't registered as Building.\n".
				  "Please fix this by either modifying the Distribution: ".
				  "header or\n".
				  "taking the package in those distributions, too.\n";
		return 0;
	}
	
	for( $i = 0; $i < @files; ++$i ) {
		if (! -f "$main::HOME/build/$files[$i]") {
			push( @missing, $files[$i] ) ;
		}
		else {
			chomp( my $sum = `md5sum $main::HOME/build/$files[$i]` );
			push( @md5fail, $files[$i] ) if (split(/\s+/,$sum))[0] ne $md5[$i];
		}
	}
	if (@missing) {
		$short_error .= "Missing files for move: @missing\n";
		$error .= "While trying to move the built package $pkg to upload,\n".
				  "the following files mentioned in the .changes were not found:\n".
				  "@missing\n";
		return 0;
	}
	if (@md5fail) {
		$short_error .= "md5 failure during move: @md5fail\n";
		$error .= "While trying to move the built package $pkg to upload,\n".
				  "the following files had bad md5 checksums:\n".
				  "@md5fail\n";
		return 0;
	}

	my $upload_dir = "$main::HOME/upload" .
		(is_for_security( $changes ) ? "-security" : "");
	
	if (! -d $upload_dir &&!mkdir( $upload_dir, 0750 )) {
		$error .= "Cannot create directory $upload_dir";
		logger( "Cannot create dir $upload_dir\n" );
		return 0;
	}
	
	lock_file( "$upload_dir" );
	my $errs = 0;
	foreach (@files) {
		if (system "mv $main::HOME/build/$_ $upload_dir/$_") {
			logger( "Cannot move $_ to upload dir\n" );
			++$errs;
		}
	}
	if ($errs) {
		$error .= "Could not move all files to upload dir.";
		return 0;
	}
	
	my $pkg_noep = $pkg;
	$pkg_noep =~ s/_\d*:/_/;
	my $changes_name = "${pkg_noep}_$main::arch.changes";
	unlink( "$main::HOME/build/$changes_name" )
		or logger( "Cannot remove ~/build/$changes_name: $!\n" );
	open( F, ">$upload_dir/$changes_name" );
	print F $changes;
	close( F );
	unlock_file( "$upload_dir" );
	logger( "Moved $pkg to ", basename($upload_dir), "\n" );
}

sub redo_new_version {
	my $dist = shift;
	my $oldv = shift;
	my $newv = shift;
	my $err = 0;

	if (open( PIPE,"$conf::sshcmd wanna-build -v ".
			  ($conf::wanna_build_dbbase? "--database=$conf::wanna_build_dbbase ":"").
			  "--user=$conf::wanna_build_user --dist=$dist $newv 2>&1 |")) {
		while( <PIPE> ) {
			next if /^wanna-build Revision/ ||
					/^\S+: Warning: Older version / ||
					/^\S+: ok$/;
			$error .= "$_";
			$err = 1;
		}
		close( PIPE );
	}
	else {
		logger( "Can't spawn wanna-build: $!\n" );
		$error .= "Can't spawn wanna-build: $!\n";
		return;
	}
	if ($err) {
		logger( "Can't take newer version $newv due to wanna-build errors\n" );
		return;
	}
	logger( "Going to build $newv instead of $oldv\n" );

	append_to_REDO( $newv, $dist );
}

sub purge_pkg {
	my $pkg = shift;
	my $dist = shift;
	my $dir;
	local( *F );

	remove_from_REDO( $pkg );
	
	# remove .changes and .deb in build dir (if existing)
	my $pkg_noep = $pkg;
	$pkg_noep =~ s/_\d*:/_/;
	my $changes = "${pkg_noep}_$main::arch.changes";
	if (-f "build/$changes" && open( F, "<build/$changes" )) {
		local($/); undef $/;
		my $changetext = <F>;
		close( F );
		my @files = get_files_from_changes( $changetext );
		push( @files, $changes );
		logger( "Purging files: $changes\n" );
		unlink( map { "build/$_" } @files );
	}

	# schedule dir for purging
	($dir = $pkg_noep) =~ s/-[^-]*$//; # remove Debian revision
	$dir =~ s/_/-/; # change _ to -
	if (-d "build/chroot-$dist/build/$Buildd::username/$dir") {
		$dir = "build/chroot-$dist/build/$Buildd::username/$dir";
	}
	else {
		$dir = "build/$dir";
	}
	return if ! -d $dir;
	
	lock_file( "build/PURGE" );
	if (open( F, ">>build/PURGE" )) {
		print F "$dir\n";
		close( F );
		logger( "Scheduled $dir for purging\n" );
	}
	else {
		$error .= "Can't open build/PURGE: $!\n";
		logger( "Can't open build/PURGE: $!\n" );
	}
	unlock_file( "build/PURGE" );
}

sub remove_from_upload {
	my $pkg = shift;
	my($changes_f, $upload_f, $changes_text, @to_remove);
	local( *F );

	logger( "Remove $pkg from upload dir\n" );
	my $pkg_noep = $pkg;
	$pkg_noep =~ s/_\d*:/_/;
	$changes_f = "${pkg_noep}_$main::arch.changes";
	my $upload_dir = "$main::HOME/upload";
	$upload_dir .= "-security" if -f "$upload_dir-security/$changes_f";

	if (!-f "$upload_dir/$changes_f") {
		logger( "$changes_f does not exist\n" );
		return;
	}
	if (!open( F, "<$upload_dir/$changes_f" )) {
		logger( "Cannot open $upload_dir/$changes_f: $!\n" );
		return;
	}
	{ local($/); undef $/; $changes_text = <F>; }
	close( F );
	@to_remove = get_files_from_changes( $changes_text );
	
	($upload_f = $changes_f) =~ s/\.changes$/\.upload/;
	push( @to_remove, $changes_f, $upload_f );

	logger( "Removing files:\n", "@to_remove\n" );
	foreach (@to_remove) {
		unlink "$upload_dir/$_"
			or logger( "Can't remove $upload_dir/$_: $!\n" );
	}
}

sub append_to_REDO {
	my $pkg = shift;
	my $dist = shift;
	local( *F );
	
	lock_file( "build/REDO" );

	if (open( F, "build/REDO" )) {
		my @pkgs = <F>;
		close( F );
		if (grep( /^\Q$pkg\E\s/, @pkgs )) {
			logger( "$pkg is already in REDO -- not rescheduled\n" );
			goto unlock;
		}
	}

	if (open( F, ">>build/REDO" )) {
		print F "$pkg $dist\n";
		close( F );
		logger( "Scheduled $pkg for rebuild\n" );
	}
	else {
		$error .= "Can't open build/REDO: $!\n";
		logger( "Can't open build/REDO: $!\n" );
	}

  unlock:
	unlock_file( "build/REDO" );
}

sub remove_from_REDO {
	my $pkg = shift;
	local( *F );
	
	lock_file( "build/REDO" );
	goto unlock if !open( F, "<build/REDO" );
	my @pkgs = <F>;
	close( F );
	if (!open( F, ">build/REDO" )) {
		logger( "Can't open REDO for writing: $!\n",
				"Would write: @pkgs\nminus $pkg\n" );
		goto unlock;
	}
	my $done = 0;
	foreach (@pkgs) {
		if (/^\Q$pkg\E\s/) {
			++$done;
		}
		else {
			print F $_;
		}
	}
	close( F );
	logger( "Deleted $pkg from REDO list.\n" ) if $done;
  unlock:
	unlock_file( "build/REDO" );
	return $done;
}

sub append_to_SKIP {
	my $pkg = shift;
	local( *F );

	return if !open( F, "<build/build-progress" );
	my @lines = <F>;
	close( F );

	if (grep( /^\s*\Q$pkg\E$/, @lines )) {
		# pkg is in build-progress, but without a suffix (failed,
		# successful, currently building), so it can be skipped
		lock_file( "build/SKIP" );
		if (open( F, ">>build/SKIP" )) {
			print F "$pkg\n";
			close( F );
			logger( "Told sbuild to skip $pkg\n" );
		}
		unlock_file( "build/SKIP" );
	}
}

sub check_is_outdated {
	my $dist = shift;
	my $package = shift;
	my %newv;
	my $have_changes = 0;
	
	return 0 if !(%newv = is_outdated( $dist, $package ));

	$have_changes = 1 if $body_text =~ /^---+\s*BEGIN PGP SIGNED MESSAGE/;

	# If we have a changes file, we can see which distributions that
	# package is aimed to. Otherwise, we're out of luck because we can't see
	# reliably anymore for which distribs the package was for. Let the user
	# find out this...
	#
	# If the package is outdated in all dists we have to consider,
	# send a plain error message. If only outdated in some of them, send a
	# modified error that tells to send a restricted changes (with
	# Distribution: only for those dists where it isn't outdated), or to do
	# the action manually, because it would be (wrongly) propagated.
	goto all_outdated if !$have_changes;
	
	my @check_dists = ();
	@check_dists = get_dists_from_changes( $body_text );

	my @not_outdated = ();
	my @outdated = ();
	foreach (@check_dists) {
		if (!exists $newv{$_}) {
			push( @not_outdated, $_ );
		}
		else {
			push( @outdated, $_ );
		}
	}
	return 0 if !@outdated;
	if (@not_outdated) {
		$short_error .= "$package ($dist) partially outdated ".
						"(ok for @not_outdated)\n";
		$error .=
			"Package $package ($dist) is partially outdated.\n".
			"The following new versions have appeared in the meantime:\n ".
			join( "\n ", map { "$_: $newv{$_}" } keys %newv )."\n\n".
			"Please send a .changes for the following distributions only:\n".
		    " Distribution: ".join( " ", @not_outdated )."\n";
	}
	else {
	  all_outdated:
		$short_error .= "$package ($dist) outdated; new versions ".
						join( ", ", map { "$_:$newv{$_}" } keys %newv )."\n";
		$error .=
			"Package $package ($dist) is outdated.\n".
			"The following new versions have appeared in the meantime:\n ".
			join( "\n ", map { "$_: $newv{$_}" } keys %newv )."\n";
	}
	return 1;
}

sub is_outdated {
	my $dist = shift;
	my $pkg = shift;
	my %result = ();
	local( *F );

	lock_file( "outdated-packages" );
	goto unlock if !open( F, "<outdated-packages" );
	while( <F> ) {
		my($oldpkg, $newpkg, $t, $d) = split( /\s+/, $_ );
		$d ||= "unstable";
		if ($oldpkg eq $pkg && $d eq $dist) {
			$result{$d} = $newpkg;
		}
	}
	close( F );
  unlock:
	unlock_file( "outdated-packages" );
	return %result;
}

sub register_outdated {
	my $dist = shift;
	my $oldv = shift;
	my $newv = shift;
	my(@pkgs);
	local( *F );
	
	lock_file( "outdated-packages" );

	if (open( F, "<outdated-packages" )) {
		@pkgs = <F>;
		close( F );
	}

	if (!open( F, ">outdated-packages" )) {
		logger( "Cannot open outdated-packages for writing: $!\n" );
		goto unlock;
	}
	my $now = time;
	my @d = ();
	foreach (@pkgs) {
		my($oldpkg, $newpkg, $t, $d) = split( /\s+/, $_ );
		$d ||= "unstable";
		next if ($oldpkg eq $oldv && $d eq $dist) || ($now - $t) > 21*24*60*60;
		print F $_;
	}
	print F "$oldv $newv $now $dist\n";
	close( F );
  unlock:
	unlock_file( "outdated-packages" );
}

sub set_to_failed {
	my $pkg = shift;
	my $dist = shift;
	my $text = shift;
	my $is_bugno = 0;

	$text =~  s/^\.$/../mg;
	$is_bugno = 1 if $text =~ /^\(see #\d+\)$/;
	return if !check_state( $pkg, $dist, $is_bugno ? "Failed" : "Building" );
	
	open( PIPE, "|-" )
		or (open( STDOUT, ">/dev/null"),
			exec "$conf::sshcmd wanna-build --failed --no-down-propagation ".
			"--user=$conf::wanna_build_user ".($conf::wanna_build_dbbase?
			"--database=$conf::wanna_build_dbbase ":""). "--dist=$dist $pkg");
	print PIPE "${text}.\n";
	close( PIPE );
	if ($?) {
		my $t = "wanna-build --failed failed with status ".exitstatus($?)."\n";
		logger( $t );
		$error .= $t;
	}
	elsif ($is_bugno) {
		logger( "Bug# appended to fail message of $pkg ($dist)\n" );
	}
	else {
		logger( "Set package $pkg ($dist) to Failed\n" );
		write_stats( "failed", 1 );
	}
}

sub set_to_depwait {
	my $pkg = shift;
	my $dist = shift;
	my $deps = shift;

	open( PIPE, "|-" )
		or (open( STDOUT, ">/dev/null"),
			exec "$conf::sshcmd wanna-build --dep-wait --no-down-propagation ".
			"--user=$conf::wanna_build_user ".($conf::wanna_build_dbbase?
			"--database=$conf::wanna_build_dbbase ":""). "--dist=$dist $pkg");
	print PIPE "$deps\n";
	close( PIPE );
	if ($?) {
		my $t = "wanna-build --dep-wait failed with status ".exitstatus($?)."\n";
		logger( $t );
		$error .= $t;
	}
	else {
		logger( "Set package $pkg ($dist) to Dep-Wait\nDependencies: $deps\n" );
	}
	write_stats( "dep-wait", 1 );
}

sub give_back {
	my $pkg = shift;
	my $dist = shift;
	my $answer_cmd;

	$answer_cmd = "$conf::sshcmd wanna-build --give-back --no-down-propagation --user=$conf::wanna_build_user ".
		($conf::wanna_build_dbbase? "--database=$conf::wanna_build_dbbase ":""). "--dist=$dist $pkg";
	my $answer = `$answer_cmd`;
	if ($?) {
		$error .= "wanna-build --give-back failed:\n$answer";
	}
	else {
		logger( "Given back package $pkg ($dist)\n" );
	}
}

sub no_build {
	my $pkg = shift;
	my $dist = shift;
	my $answer_cmd;

	$answer_cmd = "$conf::sshcmd wanna-build --no-build --no-down-propagation --user=$conf::wanna_build_user ".
		($conf::wanna_build_dbbase? "--database=$conf::wanna_build_dbbase ":""). "--dist=$dist $pkg";
	my $answer = `$answer_cmd`;
	if ($?) {
		$error .= "no-build failed:\n$answer";
	}
	else {
		logger( "Package $pkg ($dist) to set Not-For-Us\n" );
	}
	write_stats( "no-build", 1 );
}

sub get_fail_msg {
	my $pkg = shift;
	my $dist = shift;
	local( *PIPE );

	$pkg =~ s/_.*//;
	if (open( PIPE, "$conf::sshcmd wanna-build --info --dist=$dist ".
		($conf::wanna_build_dbbase? "--database=$conf::wanna_build_dbbase ":""). "$pkg |" )) {
		my $msg = "";
		while( <PIPE> ) {
			if (/^\s*Old-Failed\s*:/) {
				while( <PIPE> ) {
					last if /^  \S+\s*/;
					$_ =~ s/^\s+//;
					if (/^----+\s+\S+\s+----+$/) {
						last if $msg;
					}
					else {
						$msg .= $_;
					}
				}
				last;
			}
		}
		close( PIPE );
		return $msg if $msg;
		$error .= "Couldn't find Old-Failed in info for $pkg\n";
		return "Same as previous version (couldn't extract the text)\n";
	}
	else {
		$error .= "Couldn't start wanna-build --info: $!\n";
		return "Same as previous version (couldn't extract the text)\n";
	}
}

sub check_state {
	my $pkgv = shift;
	my $dist = shift;
	my @wanted_states = @_;
	local( *PIPE );

	$pkgv =~ /^([^_]+)_(.+)/;
	my ($pkg, $vers) = ($1, $2);
	if (!open( PIPE, "$conf::sshcmd wanna-build --info ".
		($conf::wanna_build_dbbase? "--database=$conf::wanna_build_dbbase ":""). "--dist=$dist $pkg |" )){
		$error .= "Couldn't start wanna-build --info: $!\n";
		return 0;
	}

	my ($av, $as, $ab, $an);
	while( <PIPE> ) {
		$av = $1 if /^\s*Version\s*:\s*(\S+)/;
		$as = $1 if /^\s*State\s*:\s*(\S+)/;
		$ab = $1 if /^\s*Builder\s*:\s*(\S+)/;
		$an = $1 if /^\s*Binary-NMU-Version\s*:\s*(\d+)/;
	}
	close( PIPE );

	my $msg = "$pkgv($dist) check_state(@wanted_states): ";
	$av = binNMU_version($av,$an) if (defined $an);
	if ($av ne $vers) {
		$error .= $msg."version $av registered as $as\n";
		return 0;
	}
	if (!isin( $as, @wanted_states)) {
		$error .= $msg."state is $as\n";
		return 0;
	}
	if ($as eq "Building" && $ab ne $conf::wanna_build_user) {
		$error .= $msg."is building by $ab\n";
		return 0;
	}
	return 1;
}

sub check_building_any_dist {
	my $pkgv = shift;
	my @dists;
	local( *PIPE );

	$pkgv =~ /^([^_]+)_(.+)/;
	my ($pkg, $vers) = ($1, $2);
	if (!open( PIPE, "$conf::sshcmd wanna-build --info ".
		($conf::wanna_build_dbbase? "--database=$conf::wanna_build_dbbase ":""). "--dist=all $pkg |" )){
		$error .= "Couldn't start wanna-build --info: $!\n";
		return 0;
	}

	my $text;
	{ local ($/); $text = <PIPE>; }
	close( PIPE );

	while( $text =~ /^\Q$pkg\E\((\w+)\):(.*)\n((\s.*\n)*)/mg ) {
		my ($dist, $rest, $info) = ($1, $2, $3);
		next if $rest =~ /not registered/;
		my ($av, $as, $ab);
		$av = $1 if $info =~ /^\s*Version\s*:\s*(\S+)/mi;
		$as = $1 if $info =~ /^\s*State\s*:\s*(\S+)/mi;
		$ab = $1 if $info =~ /^\s*Builder\s*:\s*(\S+)/mi;
		push( @dists, $dist )
			if $av eq $vers && $as eq "Building" &&
			   $ab eq $conf::wanna_build_user;
	}
	return @dists;
}

sub get_files_from_changes {
	my $changes_text = shift;
	my(@filelines, @files);
	
	$changes_text =~ /^Files:\s*\n((^[ 	]+.*\n)*)/m;
	@filelines = split( "\n", $1 );
	foreach (@filelines) {
		push( @files, (split( /\s+/, $_ ))[5] );
	}
	return @files;
}

sub is_for_non_us {
	my $pkg = shift;
	my $changes_text = shift;

	$pkg =~ s/_.*$//;

	# check if there's a "non-US" in the sections
	$changes_text =~ /^Files:\s*\n((^[ 	]+.*\n)*)/m;
	my @filelines = split( "\n", $1 );
	foreach (@filelines) {
		return 1 if (split( /\s+/, $_ ))[3] =~ /non-us/i;
	}
	return 0;
}

sub is_for_security {
	my $changes_text = shift;

	# check if there's a "-security" in the distribution
	my @dists = get_dists_from_changes( $changes_text );
	foreach (@dists) {
		return 1 if /-security$/;
	}
	return 0;
}

sub get_dists_from_changes {
	my $changes_text = shift;
	
	$changes_text =~ /^Distribution:\s*(.*)\s*$/mi;
	return split( /\s+/, $1 );
}

sub reply {
	my $text = shift;
	my( $to, $subj, $quoting );

	$to = $header{'reply-to'} || $header{'from'};
	$subj = $header{'subject'};
	$subj = "Re: $subj" if $subj !~ /^Re\S{0,2}:/;
	($quoting = $body_text) =~ s/\n+$/\n/;
	$quoting =~ s/^/> /mg;
	
	send_mail( $to, $subj, "$quoting\n$text",
			   "In-Reply-To: $header{'message-id'}\n" );
}

sub is_blacklisted {
	my $addr = shift;
	local( *BL );

	$addr = $1 if $addr =~ /<(.*)>/;
	return 0 if !open( BL, "<mail-blacklist" );
	while( <BL> ) {
		chomp;
		if ($addr =~ /$_$/) {
			close( BL );
			return 1;
		}
	}
	close( BL );
	return 0;
}

sub add_error_mail {
	local( *F );
	my $now = time;
	my @em = ();

	if (open( F, "<mail-errormails" )) {
		chomp( @em = <F> );
		close( F );
	}
	push( @em, $now );
	shift @em while @em && ($now - $em[0]) > $conf::error_mail_window;

	if (@em) {
		open( F, ">mail-errormails" );
		print F join( "\n", @em ), "\n";
		close( F );
	}
	else {
		unlink( "mail-errormails" );
	}

	return scalar(@em);
}

BEGIN { %main::dist_order = ( stable => 0, frozen => 1, unstable => 2 ); }
sub dist_cmp {
	my $d1 = shift;
	my $d2 = shift;

	return $main::dist_order{$d1} <=> $main::dist_order{$d2};
}

sub dist_list_ge {
	my $d = shift;
	my @l = ();

	foreach (keys %main::dist_order) {
		push( @l, $_ ) if $main::dist_order{$_} >= $main::dist_order{$d};
	}
	return @l;
}