# buildd-mail: mail answer processor for buildd
# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
# Copyright © 2009 Roger Leigh <rleigh@debian.org>
# Copyright © 2005 Ryan Murray <rmurray@debian.org>
#
# 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, see
# <http://www.gnu.org/licenses/>.
#
#######################################################################

package Buildd::Mail;

use strict;
use warnings;

use Buildd       qw(ll_send_mail lock_file unlock_file send_mail exitstatus);
use Buildd::Conf qw();
use Buildd::Base;
use Sbuild qw(binNMU_version $devnull);
use Sbuild::ChrootRoot;
use Buildd::Client;
use POSIX;
use File::Basename;
use MIME::QuotedPrint;
use MIME::Base64;
use Encode;

BEGIN {
	use Exporter ();
	our (@ISA, @EXPORT);

	@ISA = qw(Exporter Buildd::Base);

	@EXPORT = qw();
}

sub new {
	my $class = shift;
	my $conf  = shift;

	my $self = $class->SUPER::new($conf);
	bless($self, $class);

	$self->set('Mail Error',       undef);
	$self->set('Mail Short Error', undef);
	$self->set('Mail Header',      {});
	$self->set('Mail Body Text',   '');

	$self->open_log();

	return $self;
}

sub run {
	my $self = shift;

	chdir($self->get_conf('HOME'));

	$self->set('Mail Error',       undef);
	$self->set('Mail Short Error', undef);
	$self->set('Mail Header',      {});
	$self->set('Mail Body Text',   '');

	$self->process_mail();

	return 0;
}

sub process_mail () {
	my $self = shift;

	# Note: Mail Header (to|from|subject|message-id|date) are mandatory.
	# Check for these and bail out if not present.
	my $header_text = "";
	my $lastheader  = "";

	$self->set('Mail Header', {});

	$self->set('Mail Error',       '');
	$self->set('Mail Short Error', '');
	$self->set('Mail Header',      {});
	$self->set('Mail Body Text',   '');

	while (<STDIN>) {
		$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/;
			$self->get('Mail Header')->{$hname} = $2;
			$lastheader = $_;
			chomp($lastheader);
		} else {
			$lastheader = "";
		}
	}
	while (<STDIN>) {
		last if !/^\s*$/;
	}

	$self->set('Mail Body Text', $self->get('Mail Body Text') . $_)
	  if defined($_);

	if (!eof) {
		local ($/);
		undef $/;
		$self->set('Mail Body Text', $self->get('Mail Body Text') . <STDIN>);
	}

	if ($self->get('Mail 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 = $self->add_error_mail();
		if ($n > 5) {
			$self->log(
				"Too much error mails ($n) within ",
				int($self->get_conf('ERROR_MAIL_WINDOW') / (60 * 60)),
				" hours\n",
				"Not forwarding mail from "
				  . $self->get('Mail Header')->{'from'} . "\n",
				"Subject: " . $self->get('Mail Header')->{'subject'} . "\n"
			);
			return;
		}
	}

	goto forward_mail if !$self->get('Mail Header')->{'subject'};
	my $subject = $self->get('Mail Header')->{'subject'};
	Encode::from_to($subject, "MIME-Header", "utf-8");

	if ($subject
		=~ /^Re: Log for \S+ build of (\S+)(?: on [\w-]+)? \(dist=(\S+)\)/i) {
		# reply to a build log
		my ($package, $dist_name) = ($1, $2);

		my $dist_config = $self->get_dist_config_by_name($dist_name);
		return if (!$dist_config);    #get_dist_config sets the error mail

		my $text = $self->get('Mail Body Text');
		$text =~ /^(\S+)/;
		$self->set('Mail Body Text', $text);
		if (defined($self->get('Mail Header')->{'content-transfer-encoding'}))
		{
			# Decode the mail if necessary.
			if ($self->get('Mail Header')->{'content-transfer-encoding'}
				=~ /quoted-printable/) {
				$self->set('Mail Body Text',
					decode_qp($self->get('Mail Body Text')));
			} elsif ($self->get('Mail Header')->{'content-transfer-encoding'}
				=~ /base64/) {
				$self->set('Mail Body Text',
					decode_base64($self->get('Mail Body Text')));
			}
		}
		my $keyword = $1;
		my $from    = $self->get('Mail Header')->{'from'};
		$from = $1 if $from =~ /<(.+)>/;
		$self->log("Log reply from $from\n");
		my %newv;

		if ($keyword =~ /^not-for-us/) {
			$self->no_build($package, $dist_config);
			$self->purge_pkg($package, $dist_config);
		} elsif ($keyword =~ /^up(l(oad)?)?-rem/) {
			$self->remove_from_upload($package, $dist_config);
		} elsif ($self->check_is_outdated($dist_config, $package)) {
			# Error has been set already -> no action here
		} elsif ($keyword =~ /^fail/) {
			my $text = $self->get('Mail Body Text');
			$text =~ s/^fail.*\n(\s*\n)*//;
			$text =~ s/\n+$/\n/;
			$self->set_to_failed($package, $dist_config, $text);
			$self->purge_pkg($package, $dist_config);
		} elsif ($keyword =~ /^ret/) {
			if (
				!$self->check_state(
					$package, $dist_config,
					qw(Built Building Build-Attempted)
				)
			) {
				# Error already set
			} else {
				$self->append_to_REDO($package, $dist_config);
			}
		} elsif ($keyword =~ /^d(ep(endency)?)?-(ret|w)/) {
			if (
				!$self->check_state(
					$package, $dist_config,
					qw(Built Building Build-Attempted)
				)
			) {
				# Error already set
			} else {
				$self->get('Mail Body Text') =~ /^\S+\s+(.*)$/m;
				my $deps = $1;
				$self->set_to_depwait($package, $dist_config, $deps);
				$self->purge_pkg($package, $dist_config);
			}
		} elsif ($keyword =~ /^man/) {
			if (
				!$self->check_state(
					$package, $dist_config,
					qw(Built Building Build-Attempted)
				)
			) {
				# Error already set
			} else {
				# no action
				$self->log("$package($dist_name) will be finished manually\n");
			}
		} elsif ($keyword =~ /^newv/) {
			# build a newer version instead
			$self->get('Mail Body Text') =~ /^newv\S*\s+(\S+)/;
			my $newv = $1;
			if ($newv =~ /_/) {
				$self->log("Removing unneeded package name from $newv\n");
				$newv =~ s/^.*_//;
				$self->log("Result: $newv\n");
			}
			my $pkgname;
			($pkgname = $package) =~ s/_.*$//;
			$self->redo_new_version($dist_config, $package,
				"${pkgname}_${newv}");
			$self->purge_pkg($package, $dist_config);
		} elsif ($keyword =~ /^(give|back)/) {
			$self->get('Mail Body Text') =~ /^(give|back) ([-0-9]+)/;
			my $pri = $1;
			if (
				!$self->check_state(
					$package, $dist_config,
					qw(Built Building Build-Attempted)
				)
			) {
				# Error already set
			} else {
				$self->give_back($package, $dist_config);
				$self->purge_pkg($package, $dist_config);
			}
		} elsif ($keyword =~ /^purge/) {
			$self->purge_pkg($package, $dist_config);
		} elsif (
			$self->get('Mail Body Text') =~ /^---+\s*BEGIN PGP SIGNED MESSAGE/)
		{
			if (
				$self->prepare_for_upload(
					$package, $self->get('Mail Body Text'))
			) {
				$self->purge_pkg($package, $dist_config);
			}
		} elsif ($self->get('Mail Body Text') =~ /^--/
			&& $self->get('Mail Header')->{'content-type'}
			=~ m,multipart/signed,) {
			my ($prot)
			  = ($self->get('Mail Header')->{'content-type'}
				  =~ m,protocol="([^"]*)",);
			my ($bound)
			  = ($self->get('Mail Header')->{'content-type'}
				  =~ m,boundary="([^"]*)",);
			my $text = $self->get('Mail Body Text');
			$text
			  =~ s,^--\Q$bound\E\nContent-Type: text/plain; charset=us-ascii\n\n,-----BEGIN PGP SIGNED MESSAGE-----\n\n,;
			$text
			  =~ s,--\Q$bound\E\nContent-Type: application/pgp-signature\n\n,,;
			$text =~ s,\n\n--\Q$bound\E--\n,,;
			$self->set('Mail Body Text', $text);
			if (
				$self->prepare_for_upload(
					$package, $self->get('Mail Body Text'))
			) {
				$self->purge_pkg($package, $dist_config);
			}
		} else {
			$self->set(
				'Mail Short Error',
				$self->get('Mail Short Error')
				  . "Bad keyword in answer $keyword\n"
			);
			$self->set(
				'Mail Error',
				$self->get('Mail 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_name) = ($1, $2);

		my $dist_config = $self->get_dist_config_by_name($dist_name);
		return if (!$dist_config);    #get_dist_config sets the error mail

		$self->get('Mail Body Text') =~ /^(\S+)/;
		my $keyword = $1;
		$self->log("Should-build reply for $package($dist_name)\n");
		if ($self->check_is_outdated($dist_config, $package)) {
			# Error has been set already -> no action here
		} elsif (
			!$self->check_state(
				$package, $dist_config, qw(Built Building Build-Attempted)
			)
		) {
			# Error already set
		} elsif ($keyword =~ /^(build|ok)/) {
			$self->append_to_REDO($package, $dist_config);
		} elsif ($keyword =~ /^fail/) {
			my $text = $self->get_fail_msg($package, $dist_config);
			$self->set_to_failed($package, $dist_config, $text);
		} elsif ($keyword =~ /^(not|no-b)/) {
			$self->no_build($package, $dist_config);
		} elsif ($keyword =~ /^(give|back)/) {
			$self->give_back($package, $dist_config);
		} else {
			$self->set(
				'Mail Short Error',
				$self->get('Mail Short Error')
				  . "Bad keyword in answer $keyword\n"
			);
			$self->set(
				'Mail Error',
				$self->get('Mail 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
		my $text = $self->get('Mail Body Text');
		goto forward_mail if $text !~ /uploaded successfully/mi;
		$self->log("$job processed by upload queue\n")
		  if $self->get_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_dirs = $self->find_upload_dirs_for_changes_file($changes_f);

		if ((scalar @upload_dirs) < 1) {
			$self->log("Can't identify upload directory for $changes_f!\n");
			return 0;
		} elsif ((scalar @upload_dirs) > 1) {
			$self->log(
"Found more than one upload directory for $changes_f - not deleting binaries!\n"
			);
			return 0;
		}
		my $upload_dir = $upload_dirs[0];

		if (-f "$upload_dir/$changes_f" && open(F, "<$upload_dir/$changes_f"))
		{
			local ($/);
			undef $/;
			my $changetext = <F>;
			close(F);
			push(@to_remove, $self->get_files_from_changes($changetext));
		} else {
			foreach (split("\n", $self->get('Mail 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//;
		$self->log("$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 = $self->get_dists_from_changes($changes_text);
		} else {
			$self->log(
"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 $self->get_conf('HOME')
						. "/build/chroot-$dist"
						&& -w $self->get_conf('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(
								qw(mv --),
								"$upload_dir/$_",
								$self->get_conf('HOME')
								  . "/build/chroot-$dist/var/cache/apt/archives/"
							)
						) {
							$self->log(
								"Cannot move $upload_dir/$_ to cache dir\n");
						} else {
							next FILE;
						}
					}
				}
			}
			unlink "$upload_dir/$_"
			  or $self->log("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//;
		$self->log("$pkgv must be manually dinstall-ed -- delayed\n");
	} elsif ($subject =~ /^new version of (\S+) \(dist=(\S+)\)$/) {
		# notice from wanna-build
		my ($pkg, $dist_name) = ($1, $2);
		my $dist_config = $self->get_dist_config_by_name($dist_name);
		goto forward
		  if $self->get('Mail Body Text') !~ /^in version (\S+)\.$/m;
		my $pkgv = $pkg . "_" . $1;
		$self->get('Mail Body Text') =~ /new source version (\S+)\./m;
		my $newv = $1;
		$self->log(
			"Build of $pkgv ($dist_name) obsolete -- new version $newv\n");
		$self->register_outdated($dist_name, $pkgv, $pkg . "_" . $newv);

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

	if ($self->get('Mail Error')) {
		$self->log("Error: ",
			$self->get('Mail Short Error') || $self->get('Mail Error'));
		$self->reply(
			"Your mail could not be processed:\n" . $self->get('Mail Error'));
	}
	return;

  forward_mail:
	my $header = $self->get('Mail Header');
	$self->log("Mail from $header->{'from'}\nSubject: $subject\n");
	if ($self->is_blacklisted($self->get('Mail Header')->{'from'})) {
		$self->log("Address is blacklisted, deleting mail.\n");
	} else {
		$self->log("Not for me, forwarding to admin\n");
		ll_send_mail(
			$self->get_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"
				: ""
			  )
			  . (
				$header->{'content-type'}
				? "Content-Type: $header->{'content-type'}\n"
				: ""
			  )
			  . "Resent-From: $Buildd::gecos <$Buildd::username\@$Buildd::hostname>\n"
			  . "Resent-To: "
			  . $self->get_conf('ADMIN_MAIL') . "\n\n"
			  . $self->get('Mail Body Text'));
	}
}

sub prepare_for_upload ($$) {
	my $self    = shift;
	my $pkg     = shift;
	my $changes = shift;

	$changes =~ s/\n+$/\n/;

	my (@files, @md5, @missing, @md5fail, $i);

	my @to_dists = $self->get_dists_from_changes($changes);
	if (!@to_dists) {    # probably not a valid changes

		$self->set('Mail Short Error', $self->get('Mail Error'));
		$self->set(
			'Mail Error',
			$self->get('Mail Error')
			  . "Couldn't find a valid Distribution: line.\n"
		);
		return 0;
	}

	my $changes_filename_arch = $self->get_conf('ARCH');
	#Try to extract the arch from the actual changes file (see #566398)
	if ($changes =~ /^Architecture:\s*(.+)/m) {
		my @arches = grep { $_ ne "all" } split /\s+/, $1;
		if (@arches > 1) {
			$changes_filename_arch = "multi";
		} else {
			$changes_filename_arch = $arches[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
		$self->set('Mail Short Error', $self->get('Mail Error'));
		$self->set('Mail Error',
			$self->get('Mail Error') . "No files listed in changes.\n");
		return 0;
	}
	my @wrong_dists = ();
	foreach my $d (@to_dists) {
		push(@wrong_dists, $d)
		  if !$self->check_state(
			$pkg,
			$self->get_dist_config_by_name($d),
			qw(Building Built Install-Wait Reupload-Wait Build-Attempted)
		  );
	}
	if (@wrong_dists) {
		$self->set('Mail Short Error', $self->get('Mail Error'));
		$self->set(
			'Mail Error',
			$self->get('Mail 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 $self->get_conf('HOME') . "/build/$files[$i]") {
			push(@missing, $files[$i]);
		} else {
			my $home = $self->get_conf('HOME');
			chomp(my $sum = `md5sum $home/build/$files[$i]`);
			push(@md5fail, $files[$i]) if (split(/\s+/, $sum))[0] ne $md5[$i];
		}
	}
	if (@missing) {
		$self->set(
			'Mail Short Error',
			$self->get('Mail Short Error')
			  . "Missing files for move: @missing\n"
		);
		$self->set(
			'Mail Error',
			$self->get('Mail 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) {
		$self->set(
			'Mail Short Error',
			$self->get('Mail Short Error')
			  . "md5 failure during move: @md5fail\n"
		);
		$self->set(
			'Mail Error',
			$self->get('Mail 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_dirs = $self->get_upload_queue_dirs($changes);

	my $pkg_noep = $pkg;
	$pkg_noep =~ s/_\d*:/_/;
	my $changes_name = $pkg_noep . "_" . $changes_filename_arch . ".changes";

	for my $upload_dir (@upload_dirs) {
		if (!-d $upload_dir && !mkdir($upload_dir, 0750)) {
			$self->set(
				'Mail Error',
				$self->get('Mail Error')
				  . "Cannot create directory $upload_dir"
			);
			$self->log("Cannot create dir $upload_dir\n");
			return 0;
		}
	}

	my $errs = 0;
	for my $upload_dir (@upload_dirs) {
		lock_file($upload_dir);
		foreach (@files) {
			if (
				system(
					'cp',                                  '--',
					$self->get_conf('HOME') . "/build/$_", "$upload_dir/$_"
				)
			) {
				$self->log("Cannot copy $_ to $upload_dir/\n");
				++$errs;
			}
		}

		open(F, ">$upload_dir/$changes_name");
		print F $changes;
		close(F);
		unlock_file($upload_dir);
		$self->log("Moved $pkg to ", basename($upload_dir), "\n");
	}

	foreach (@files) {
		if (!unlink($self->get_conf('HOME') . "/build/$_")) {
			$self->log("Cannot remove build/$_\n");
			++$errs;
		}
	}

	if ($errs) {
		$self->set(
			'Mail Error',
			$self->get('Mail Error')
			  . "Could not move all files to upload dir."
		);
		return 0;
	}

	unlink($self->get_conf('HOME') . "/build/$changes_name")
	  or $self->log(
		"Cannot remove " . $self->get_conf('HOME') . "/$changes_name: $!\n");
}

sub redo_new_version ($$$) {
	my $self        = shift;
	my $dist_config = shift;
	my $oldv        = shift;
	my $newv        = shift;

	my $err = 0;

	my $db   = $self->get_db_handle($dist_config);
	my $pipe = $db->pipe_query('-v', $newv);
	if ($pipe) {
		while (<$pipe>) {
			next
			  if /^wanna-build Revision/
			  || /^\S+: Warning: Older version /
			  || /^\S+: ok$/;
			$self->set('Mail Error', $self->get('Mail Error') . $_);
			$err = 1;
		}
		close($pipe);
	} else {
		$self->log("Can't spawn wanna-build: $!\n");
		$self->set('Mail Error',
			$self->get('Mail Error') . "Can't spawn wanna-build: $!\n");
		return;
	}
	if ($err) {
		$self->log(
			"Can't take newer version $newv due to wanna-build errors\n");
		return;
	}
	$self->log("Going to build $newv instead of $oldv\n");

	$self->append_to_REDO($newv, $dist_config);
}

sub purge_pkg ($$) {
	my $self        = shift;
	my $pkg         = shift;
	my $dist_config = shift;
	my $dist_name   = $dist_config->get('DIST_NAME');

	my $dir;
	local (*F);

	$self->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}_" . $self->get_conf('ARCH') . ".changes";
	if (-f "build/$changes" && open(F, "<build/$changes")) {
		local ($/);
		undef $/;
		my $changetext = <F>;
		close(F);
		my @files = $self->get_files_from_changes($changetext);
		push(@files, $changes);
		$self->log("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_name/build/$Buildd::username/$dir") {
		$dir = "build/chroot-$dist_name/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);
		$self->log("Scheduled $dir for purging\n");
	} else {
		$self->set('Mail Error',
			$self->get('Mail Error') . "Can't open build/PURGE: $!\n");
		$self->log("Can't open build/PURGE: $!\n");
	}
	unlock_file("build/PURGE");
}

sub remove_from_upload ($) {
	my $self        = shift;
	my $pkg         = shift;
	my $dist_config = shift;

	my ($changes_f, $upload_f, $changes_text, @to_remove);
	local (*F);

	$self->log("Remove $pkg from upload dir\n");
	my $pkg_noep = $pkg;
	$pkg_noep =~ s/_\d*:/_/;
	$changes_f = "${pkg_noep}_" . $self->get_conf('ARCH') . ".changes";

	my $upload_dir = $self->get_conf('HOME') . '/'
	  . $dist_config->get('DUPLOAD_LOCAL_QUEUE_DIR');

	if (!-f "$upload_dir/$changes_f") {
		$self->log("$changes_f does not exist\n");
		return;
	}
	if (!open(F, "<$upload_dir/$changes_f")) {
		$self->log("Cannot open $upload_dir/$changes_f: $!\n");
		return;
	}
	{ local ($/); undef $/; $changes_text = <F>; }
	close(F);
	@to_remove = $self->get_files_from_changes($changes_text);

	($upload_f = $changes_f) =~ s/\.changes$/\.upload/;
	push(@to_remove, $changes_f, $upload_f);

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

sub append_to_REDO ($$) {
	my $self        = shift;
	my $pkg         = shift;
	my $dist_config = shift;
	my $dist_name   = $dist_config->get('DIST_NAME');

	local (*F);

	lock_file("build/REDO");

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

	if (open(F, ">>build/REDO")) {
		print F "$pkg $dist_name\n";
		close(F);
		$self->log("Scheduled $pkg for rebuild\n");
	} else {
		$self->set('Mail Error',
			$self->get('Mail Error') . "Can't open build/REDO: $!\n");
		$self->log("Can't open build/REDO: $!\n");
	}

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

sub remove_from_REDO ($) {
	my $self = shift;
	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")) {
		$self->log(
			"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);
	$self->log("Deleted $pkg from REDO list.\n") if $done;
  unlock:
	unlock_file("build/REDO");
	return $done;
}

sub append_to_SKIP ($) {
	my $self = shift;
	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);
			$self->log("Told sbuild to skip $pkg\n");
		}
		unlock_file("build/SKIP");
	}
}

sub check_is_outdated ($$) {
	my $self        = shift;
	my $dist_config = shift;
	my $package     = shift;
	my $dist_name   = $dist_config->get('DIST_NAME');

	my %newv;
	return 0 if !(%newv = $self->is_outdated($dist_name, $package));

	my $have_changes = 1
	  if $self->get('Mail 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 = $self->get_dists_from_changes($self->get('Mail 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) {
		$self->set(
			'Mail Short Error',
			$self->get('Mail Short Error')
			  . "$package ($dist_name) partially outdated "
			  . "(ok for @not_outdated)\n"
		);
		$self->set(
			'Mail Error',
			$self->get('Mail Error')
			  . "Package $package ($dist_name) 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:
		$self->set(
			'Mail Short Error',
			$self->get('Mail Short Error')
			  . "$package ($dist_name) outdated; new versions "
			  . join(", ", map { "$_:$newv{$_}" } keys %newv) . "\n"
		);
		$self->set(
			'Mail Error',
			$self->get('Mail Error')
			  . "Package $package ($dist_name) 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 $self      = shift;
	my $dist_name = 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_name) {
			$result{$d} = $newpkg;
		}
	}
	close(F);
  unlock:
	unlock_file("outdated-packages");
	return %result;
}

sub register_outdated ($$$) {
	my $self = shift;
	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")) {
		$self->log("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 $self        = shift;
	my $pkg         = shift;
	my $dist_config = shift;
	my $text        = shift;
	my $dist_name   = $dist_config->get('DIST_NAME');

	my $is_bugno = 0;

	$text =~ s/^\.$/../mg;
	$is_bugno = 1 if $text =~ /^\(see #\d+\)$/;
	return
	  if !$self->check_state($pkg, $dist_config,
		$is_bugno
		? "Failed"
		: qw(Built Building Build-Attempted BD-Uninstallable));

	my $db   = $self->get_db_handle($dist_config);
	my $pipe = $db->pipe_query_out('--failed', $pkg);
	if ($pipe) {
		print $pipe "${text}.\n";
		close($pipe);
	}
	if ($?) {
		my $t
		  = "wanna-build --failed failed with status " . exitstatus($?) . "\n";
		$self->log($t);
		$self->set('Mail Error', $self->get('Mail Error') . $t);
	} elsif ($is_bugno) {
		$self->log("Bug# appended to fail message of $pkg ($dist_name)\n");
	} else {
		$self->log("Set package $pkg ($dist_name) to Failed\n");
		$self->write_stats("failed", 1);
	}
}

sub set_to_depwait ($$$) {
	my $self        = shift;
	my $pkg         = shift;
	my $dist_config = shift;
	my $deps        = shift;
	my $dist_name   = $dist_config->get('DIST_NAME');

	my $db   = $self->get_db_handle($dist_config);
	my $pipe = $db->pipe_query_out('--dep-wait', $pkg);
	if ($pipe) {
		print $pipe "$deps\n";
		close($pipe);
	}
	if ($?) {
		my $t = "wanna-build --dep-wait failed with status "
		  . exitstatus($?) . "\n";
		$self->log($t);
		$self->set('Mail Error', $self->get('Mail Error') . $t);
	} else {
		$self->log(
			"Set package $pkg ($dist_name) to Dep-Wait\nDependencies: $deps\n"
		);
	}
	$self->write_stats("dep-wait", 1);
}

sub give_back ($$) {
	my $self        = shift;
	my $pkg         = shift;
	my $dist_config = shift;
	my $dist_name   = $dist_config->get('DIST_NAME');

	my $answer;

	my $db   = $self->get_db_handle($dist_config);
	my $pipe = $db->pipe_query('--give-back', $pkg);
	if ($pipe) {
		$answer = <$pipe>;
		close($pipe);
	}
	if ($?) {
		$self->set(
			'Mail Error',
			$self->get('Mail Error')
			  . "wanna-build --give-back failed:\n$answer"
		);
	} else {
		$self->log("Given back package $pkg ($dist_name)\n");
	}
}

sub no_build ($$) {
	my $self        = shift;
	my $pkg         = shift;
	my $dist_config = shift;
	my $dist_name   = $dist_config->get('DIST_NAME');
	my $answer_cmd;

	my $answer;

	my $db   = $self->get_db_handle($dist_config);
	my $pipe = $db->pipe_query('--no-build', $pkg);
	if ($pipe) {
		$answer = <$pipe>;
		close($pipe);
	}
	if ($?) {
		$self->set('Mail Error',
			$self->get('Mail Error') . "no-build failed:\n$answer");
	} else {
		$self->log("Package $pkg ($dist_name) to set Not-For-Us\n");
	}
	$self->write_stats("no-build", 1);
}

sub get_fail_msg ($$) {
	my $self        = shift;
	my $pkg         = shift;
	my $dist_config = shift;
	my $dist_name   = $dist_config->get('DIST_NAME');

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

	my $db   = $self->get_db_handle($dist_config);
	my $pipe = $db->pipe_query('--info', $pkg);
	if ($pipe) {
		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;
		$self->set(
			'Mail Error',
			$self->get('Mail Error')
			  . "Couldn't find Old-Failed in info for $pkg\n"
		);
		return "Same as previous version (couldn't extract the text)\n";
	} else {
		$self->set(
			'Mail Error',
			$self->get('Mail Error')
			  . "Couldn't start wanna-build --info: $!\n"
		);
		return "Same as previous version (couldn't extract the text)\n";
	}
}

sub check_state ($@) {
	my $self       = shift;
	my $mail_error = $self->get('Mail Error');
	my $retval     = $self->check_state_internal(@_);
	# check if we should retry the call
	if ($retval == -1) {
		my $interval = int(rand(120));
		$self->log("Retrying --info in $interval seconds...\n");
		# reset error to old value
		$self->set('Mail Error', $mail_error);
		# 0..120s of sleep ought to be enough for retrying;
		# for mail bursts, this should get us out of the
		# crticial mass
		sleep $interval;
		$retval = $self->check_state_internal(@_);
		# remap the -1 retry code to failure
		if ($retval == -1) {
			return 0;
		} else {
			return $retval;
		}
	}
	return $retval;
}

sub check_state_internal ($$@) {
	my $self          = shift;
	my $pkgv          = shift;
	my $dist_config   = shift;
	my @wanted_states = @_;
	my $dist_name     = $dist_config->get('DIST_NAME');

	$pkgv =~ /^([^_]+)_(.+)/;
	my ($pkg, $vers) = ($1, $2);

	my $db   = $self->get_db_handle($dist_config);
	my $pipe = $db->pipe_query('--info', $pkg);
	if (!$pipe) {
		$self->set(
			'Mail Error',
			$self->get('Mail Error')
			  . "Couldn't start wanna-build --info: $!\n"
		);
		$self->log("Couldn't start wanna-build --info: $!\n");
		# let check_state() retry if needed
		return -1;
	}

	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);

	if ($?) {
		my $t
		  = "wanna-build --info failed with status " . exitstatus($?) . "\n";
		$self->log($t);
		$self->set('Mail Error', $self->get('Mail Error') . $t);
		return 0;
	}

	my $msg = "$pkgv($dist_name) check_state(@wanted_states): ";
	$av = binNMU_version($av, $an, undef) if (defined $an);
	if ($av ne $vers) {
		$self->set(
			'Mail Error',
			$self->get('Mail Error')
			  . $msg
			  . "version $av registered as $as\n"
		);
		return 0;
	}
	if (!Buildd::isin($as, @wanted_states)) {
		$self->set('Mail Error',
			$self->get('Mail Error') . $msg . "state is $as\n");
		return 0;
	}
	if ($as eq "Building" && $ab ne $dist_config->get('WANNA_BUILD_DB_USER')) {
		$self->set('Mail Error',
			$self->get('Mail Error') . $msg . "is building by $ab\n");
		return 0;
	}
	return 1;
}

sub check_building_any_dist ($) {
	my $self = shift;
	my $pkgv = shift;

	my @dists;

	$pkgv =~ /^([^_]+)_(.+)/;
	my ($pkg, $vers) = ($1, $2);

	for my $dist_config (@{ $self->get_conf('DISTRIBUTIONS') }) {
		my $dist_name = $dist_config->get('DIST_NAME');

		my $db   = $self->get_db_handle($dist_config);
		my $pipe = $db->pipe_query('--info', $pkg);
		if (!$pipe) {
			$self->set(
				'Mail Error',
				$self->get('Mail 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 $self->get_conf('WANNA_BUILD_DB_USER');
		}
	}
	return @dists;
}

sub get_files_from_changes ($) {
	my $self         = shift;
	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 get_dists_from_changes ($) {
	my $self         = shift;
	my $changes_text = shift;

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

sub get_upload_queue_dirs ($) {
	my $self         = shift;
	my $changes_text = shift;

	my %upload_dirs;
	my @dists = $self->get_dists_from_changes($changes_text);
	for my $dist_config (@{ $self->get_conf('DISTRIBUTIONS') }) {
		my $upload_dir = $self->get_conf('HOME') . '/'
		  . $dist_config->get('DUPLOAD_LOCAL_QUEUE_DIR');

		if (grep { $dist_config->get('DIST_NAME') eq $_ } @dists) {
			$upload_dirs{$upload_dir} = 1;
		}
	}
	return keys %upload_dirs;
}

sub find_upload_dirs_for_changes_file ($) {
	my $self              = shift;
	my $changes_file_name = shift;

	my %dirs;

	for my $dist_config (@{ $self->get_conf('DISTRIBUTIONS') }) {
		my $upload_dir = $self->get_conf('HOME') . '/'
		  . $dist_config->get('DUPLOAD_LOCAL_QUEUE_DIR');
		if (-f "$upload_dir/$changes_file_name") {
			$dirs{$upload_dir} = 1;
		}
	}

	return keys %dirs;
}

sub reply ($) {
	my $self = shift;
	my $text = shift;

	my ($to, $subj, $quoting);

	$to = $self->get('Mail Header')->{'reply-to'}
	  || $self->get('Mail Header')->{'from'};
	$subj = $self->get('Mail Header')->{'subject'};
	$subj = "Re: $subj" if $subj !~ /^Re\S{0,2}:/;
	($quoting = $self->get('Mail Body Text')) =~ s/\n+$/\n/;
	$quoting =~ s/^/> /mg;

	send_mail($to, $subj, "$text\n$quoting",
		"In-Reply-To: " . $self->get('Mail Header')->{'message-id'} . "\n");
}

sub is_blacklisted ($) {
	my $self = shift;
	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 () {
	my $self = shift;

	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]) > $self->get_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);
}

1;
