#!/usr/bin/perl -w
# autor: Michał Mirosław
use v5.6.0;
use strict;
use IO::Socket::INET6;
our $BOTNAME = "mqNewsTeachBot";
our $VERSION = "0.99.26";
our $CYEARS = "2002-2009";

### Domyslna konfiguracja

our $NNTP_SERVER = "127.0.0.1";
our $NNTP_LOCAL_ADDR = undef;
our $NNTP_TIMEOUT = 10;
our $NNTP_PERSISTENT_CONNECTION = 0;

our $FROM = "mirQowy Bot Newsowy <adres\@bota.gdzies.w.inter.net>";
our $GROUP = "test";
our @SIGNATURE = (
	"mirQowy Bot Newsowy, versyja $VERSION",
	"Komentarze: mirq-newsbot\@rere.qmqm.pl",
);

our $USER_AGENT = "$BOTNAME/$VERSION";

our $CHARSET = "iso-8859-2";
our $PREFER_CHARSET = "iso-8859-2";

our $REPLY_ALWAYS = 0;
our $SIGLINES_LIMIT = 4;
our $SIG_IGNORE_1EMPTY = 1;
our $YELL_ON_ATTACHMENTS = 1;
our $LINELEN_LIMIT = 72;
our $LINELEN_MAX = 80;
our $SUBJECT_MAXLEN = 70;

our $STATUS_INTERVAL = 30;

our $LINE_HEAD = "linia";
our $LONG_SUBJECT_SUBST = "[jakiś przydługi temat]";
our $EMPTY_SUBJECT_SUBST = "[pusty temat]";

### Qniec czesci serwisowalnych przez userów ;)

our %error_info = ();
our @error_heading = ("[   ]", "[-  ]", "[** ]", "[###]");

our %configfile_vars = (
	"NNTP_SERVER" => \$NNTP_SERVER,
	"NNTP_LOCAL_ADDR" => \$NNTP_LOCAL_ADDR,
	"NNTP_TIMEOUT" => \$NNTP_TIMEOUT,
	"NNTP_PERSISTENT_CONNECTION" => \$NNTP_PERSISTENT_CONNECTION,
	"FROM" => \$FROM,
	"GROUP" => \$GROUP,
	"SIGNATURE" => \@SIGNATURE,
	"USER_AGENT" => \$USER_AGENT,
	"CHARSET" => \$CHARSET,
	"PREFER_CHARSET" => \$PREFER_CHARSET,
	"SIGLINES_LIMIT" => \$SIGLINES_LIMIT,
	"SIG_IGNORE_1EMPTY" => \$SIG_IGNORE_1EMPTY,
	"STATUS_INTERVAL" => \$STATUS_INTERVAL,
	"YELL_ON_ATTACHMENTS" => \$YELL_ON_ATTACHMENTS,
	"LINELEN_LIMIT" => \$LINELEN_LIMIT,
	"LINELEN_MAX" => \$LINELEN_MAX,
	"SUBJECT_MAXLEN" => \$SUBJECT_MAXLEN,
	"LINE_HEAD" => \$LINE_HEAD,
	"LONG_SUBJECT_SUBST" => \$LONG_SUBJECT_SUBST,
	"EMPTY_SUBJECT_SUBST" => \$EMPTY_SUBJECT_SUBST,
	"REPLY_ALWAYS" => \$REPLY_ALWAYS,
	"error_heading" => \@error_heading,
	"error_info" => \%error_info
);

our $last_article_seen = 0;
our %my_articles = ();
our %known_people_bugs = ();
our %known_people_last_article = ();

our %statefile_vars = (
	"last_article_seen" => \$last_article_seen,
	"my_articles" => \%my_articles,
	"known_people_bugs" => \%known_people_bugs,
	"known_people_last_article" => \%known_people_last_article,

	"__SAVED_BY_VERSION" => \$VERSION
);

our $first_article = 0;
our $last_article = 0;

our $nntp_socket;
our $nntp_XHDR = 0;
our $nntp_XPAT = 0;
our $nntp_DATE = 0;
our $last_nntp_response = "";
our $terminating = 0;

$/ = "\r\n";

sub read_config {
	my ($file) = @_;
	our $__SAVED_BY_VERSION;

	print STDERR "Reading config from: $file\n";
	my $ret = do $file;
	unless (defined $ret) {
		print STDERR "PERL compilation errors:\n$@" if $@;
		print STDERR "PERL load error: $!\n" if $!;
		die "Config failed" unless defined wantarray and not -e $file;
		return 0;
	}
	if ($__SAVED_BY_VERSION && $__SAVED_BY_VERSION ne $VERSION) {
		print STDERR "Warning: saved by version:$__SAVED_BY_VERSION instead of: $VERSION\n";
	}
	$__SAVED_BY_VERSION = undef;
	return 1;
}

sub nntp_conversation_fail {
	my ($reason, @data) = @_;
	close $nntp_socket;
	print STDERR "NNTP Conversation failed: $reason\nLast response: $last_nntp_response\n";
	save_state("state", \%statefile_vars);
	if (@data) {
		if (open(FH, '>', 'state.fail.data')) {
			print FH join("\n", @data);
			close FH;
			print STDERR "state.fail.data written.\n";
		} else {
			print STDERR "state.fail.data create failed: $!\n";
		}
	}
	exit 1;
}

sub read_response {
	my $l = readline $nntp_socket;
	nntp_conversation_fail("connection closed: $!") unless defined $l;
	chomp $l;
	unless ($l =~ m/^([0-9][0-9][0-9])/) {
		print STDERR "Invalid response: $l\n";
		return;
	}
	my $n = $1;
	$last_nntp_response = $l;

	return $n unless wantarray;
	return ($n, $l);
}

sub read_server_line {
	my $l = readline $nntp_socket;
	chomp $l;

	nntp_conversation_fail("Connection closed: $!")
		unless defined $l;
	return if $l eq ".";
	return $l;
}

sub connect_to_server {
	if ($nntp_socket) {
		print $nntp_socket "DATE\r\n";
		my $l = readline $nntp_socket;	# just a keepalive
		return $nntp_socket if defined $l;
		print STDERR "Persistent connection died, reconnecting.\n";
	}

	$nntp_socket = IO::Socket::INET6->new(
		PeerAddr => $NNTP_SERVER,
		PeerPort => "nntp(119)",
		LocalAddr => $NNTP_LOCAL_ADDR,
		Proto => "tcp",
		Multihomed => 1,
	);
	die "Couldn't connect: $!" unless $nntp_socket;
	return unless $nntp_socket;
	$nntp_socket->autoflush(1);
	$nntp_socket->timeout(10);
	print $nntp_socket "";
	my ($n, $l) = &read_response;
	die "Grr: $l" unless $n == 200;

	print $nntp_socket "MODE READER\r\n";
	die "I cannot post !" if &read_response == 201;

	print $nntp_socket "XHDR\r\n";
	$nntp_XHDR = (&read_response != 500);
	print $nntp_socket "XPAT\r\n";
	$nntp_XPAT = (&read_response != 500);
	print $nntp_socket "DATE\r\n";
	$nntp_DATE = (&read_response != 500);
	print STDERR "Server capabilities: XHDR=$nntp_XHDR XPAT=$nntp_XPAT DATE=$nntp_DATE\n";

	return $nntp_socket;
}

sub check_group {
	print $nntp_socket "GROUP $GROUP\r\n";
	my ($n, $l) = &read_response;
	nntp_conversation_fail("Invalid GROUP response") unless $n == 211;
	my ($r, $max, $first, $last, $s) = split(/ /, $l);
	($first_article, $last_article) = ($first, $last);
	$last_article_seen = $first_article - 1
		unless $last_article_seen;
	return $nntp_socket;
}

sub disconnect {
	return unless defined $nntp_socket;
	print $nntp_socket "QUIT\r\n";
	readline $nntp_socket;		# be polite ;)
	close $nntp_socket;
	undef $nntp_socket;
}

sub get_msgid {
	my ($l, $err) = @_;

	unless ($l =~ m'(<[_$.0-9A-Za-z-]+@[0-9A-Za-z-.]+>)') {
		nntp_conversation_fail("$err - couldn't find msgid") if $err;
	}
	return $1;
}

sub post_article {
	my ($hdr_ref, $lines_ref) = @_;
	my $art = <<EOF;
From: $FROM\r
Newsgroups: $GROUP\r
User-Agent: $USER_AGENT\r
MIME-Version: 1.0\r
Content-Type: text/plain; charset=$CHARSET\r
Content-Transfer-Encoding: 8bit\r
EOF
	die "post_article: BUG: \@\$hdr_ref is odd" if @$hdr_ref % 2 != 0;
	while (my ($hdr, $val) = splice(@$hdr_ref, 0, 2)) {
		$art .= "$hdr: $val\r\n";
	}
	my @lines = @$lines_ref;
	splice(@lines, $#lines, 1) while (@lines and not $lines[$#lines]);
	map { $_ .= ' ' if $_ eq "."; } @lines;	# zabezpieczenie przed samotnymi kropkami
	$art .= "\r\n" . join("\r\n", @lines) . "\r\n";
	$art .= join("\r\n", "", "-- ", @SIGNATURE) . "\r\n"
		if scalar @SIGNATURE;
	$art .= ".\r\n";

	print $nntp_socket "POST\r\n";
	nntp_conversation_fail("Couldn't post", $art) unless &read_response == 340;
	print $nntp_socket $art;
	my ($n, $l) = &read_response;
	nntp_conversation_fail("Couldn't post article", $art) unless $n == 240;
	my $msgid = get_msgid($l, "POST reply 240");
	print STDERR "Article posted: $msgid\n";
	return $msgid;
}

sub get_server_datetime {
	return (0, 0) unless $nntp_DATE;	# FIXME

	print $nntp_socket "DATE\r\n";
	my ($n, $l) = &read_response;
	nntp_conversation_fail("Couldn't get server date and time")
		unless $n == 111 and $l =~ m/([0-9]{6,8})([0-9]{6})$/;
	return ($1, $2);
}

sub str_quote {
	my ($str) = @_;

	return unless defined $str;
	$str =~ s/(['\\])/\\$1/g;
	return "'$str'";
}

sub save_state {
	my ($fn, $varhash, $name) = @_;
	my $sort_hash = $name ? 1 : 0;
	$name = "state" unless $name;

	print STDERR "Saving $name to: $fn\n";
	open FH, ">$fn.new" or die "Couldn't create file $fn.new: $!";
	print FH "#!/usr/bin/perl\n\n";
	print FH "### Statefile saved by $BOTNAME ver. $VERSION\n### DO NOT DELETE\n\n"
		if $name eq "state";

	foreach (sort keys %$varhash) {
		my $v = $$varhash{$_};
		if (ref($v) eq "SCALAR") {
			my $vv = str_quote($$v);
			print FH "\$$_ = $vv;\n";
		} elsif (ref($v) eq "ARRAY") {
			print FH "\@$_ = (\n";
			my $n = @$v;
			foreach my $el (@$v) {
				my $elv = str_quote($el);
				my $coma = --$n ? "," : "";
				print FH "\t$elv$coma\n";
			}
			print FH ");\n";
		} elsif (ref($v) eq "HASH") {
			print FH "\%$_ = (\n";
			my @keys = keys %$v;
			@keys = sort @keys if $sort_hash;
			my $n = @keys;
			foreach my $k (@keys) {
				my $kk = str_quote($k);
				print FH "\t$kk => ";
				if (ref($$v{$k}) eq "ARRAY") {	# opisy błędów
					my @arr = @{$$v{$k}};
					print FH "[ ", shift(@arr), ", \n";
					while (my $n = str_quote(shift(@arr))) {
						my $c = (@arr ? "," : "");
						print FH "\t\t$n$c\n";
					}
					print FH "\t]";
				} else {
					print FH str_quote($$v{$k});
				}
				my $coma = --$n ? "," : "";
				print FH "$coma\n";
			}
			print FH ");\n";
		} else {
			print FH "# $_ = $v\n";
		}
	}

	print FH "\n\n1; # <- ALL OK sign; DO NOT DELETE\n";
	close FH or die "Close error: $!\n";

	rename $fn . ".new", $fn or die "Couldn't rename $fn.new to $fn: $!";
	print STDERR "State saved.\n";
}

# uzywane tylko gdy serwer nie obsluguje XHDR lub odczytujemy wszystkie naglówki
my $last_article_id = "";
my %last_article_headers = ();

sub get_article_header_wHEAD {
	my ($article, $header) = @_;
	$header = lc $header;

	if (not $article or $article ne $last_article_id) {
		print $nntp_socket "HEAD $article\r\n";
		my ($n, $l) = &read_response;
		if ($n != 221) {
			nntp_conversation_fail("HEAD failed") unless $n == 423;
			$last_article_id = undef;
			return undef;
		}
		$last_article_id = get_msgid($l, "HEAD response 221");
		%last_article_headers = ();

		my ($v, $h) = ("", "");
		while (defined ($l = &read_server_line)) {
			if ($l =~ s/^([A-Za-z0-9-]+)://) {
				$last_article_headers{$h} = $v if $h;
				($v, $h) = ("", lc $1);
			}
			$l =~ s/^\s*//;
			$v .= "\t" if $v;
			$v .= $l;
		}
		$last_article_headers{$h} = $v if $h;
	}

	return unless exists $last_article_headers{$header};
	return $last_article_headers{$header};
}

sub get_article_header {
	my ($article, $header, $pattern) = @_;

	if (defined $pattern) {
		nntp_conversation_fail("FIXME: I don't know how to apply patterns w/o XPAT")
			unless $nntp_XPAT;
		print $nntp_socket "XPAT $header $article $pattern\r\n";
		my $n = &read_response;
		nntp_conversation_fail("XPAT failed") unless &read_response == 221;
	} else {
		return get_article_header_wHEAD($article, $header)
			unless $nntp_XHDR;
		print $nntp_socket "XHDR $header $article\r\n";
		nntp_conversation_fail("XHDR failed") unless &read_response == 221;
	}

	my @list = ();
	my $l;
	while (defined ($l = &read_server_line)) {
		my ($a, $head) = split / /, $l, 2;
		push @list, $head;
	}
	return $list[0] unless wantarray;
	return @list;
}

sub select_next_article {
	$last_article_seen = $last_article;
	return if $terminating;
	print $nntp_socket "NEXT\r\n";
	my ($n, $l) = &read_response;
	if ($n == 421) {	# wiecej artykulów juz nie ma
		return;
	} elsif ($n == 420) {	# aktualny artykul przepadl
		return &select_first_new_article;
	} elsif ($n == 223) {	# jest i nastepny
		nntp_conversation_fail("Invalid 223 NEXT response - no art num")
			unless $l =~ m/^... ([0-9]+)/;
		$last_article_seen = $1;
		return $last_article_seen unless wantarray;
		return (get_msgid($l, "NEXT response 223"), $last_article_seen);
	}
	nntp_conversation_fail("Invalid NEXT response");
}

sub select_first_new_article {
	my $get_next = 1;
	print STDERR "Searching for articles in range: $last_article_seen .. $last_article\n";
	while ($last_article_seen < $last_article) {
		print $nntp_socket "STAT $last_article_seen\r\n";
		my ($n, $l) = &read_response;
		if ($n == 223) {	# artykul jeszcze jest
			return &select_next_article if $get_next;
			return $last_article_seen unless wantarray;
			return (get_msgid($l, "STAT response 223"), $last_article_seen);
		}
		nntp_conversation_fail("Invalid STAT response")
			unless $n == 423;
		print STDERR "Last seen article not found, searching forward.\n"
			if $get_next;
		++$last_article_seen;
		$get_next = 0;
	}
	return;
}

sub prune_my_articles {
	foreach (keys %my_articles) {
		delete $my_articles{$_}
			unless defined $my_articles{$_};
	}
}

sub check_to_be_quiet {
	my ($article) = @_;
	my $hname = "X-Bugs-Be-Quiet";

	my $hv = (defined $article)
		? $article->{lc $hname}
		: get_article_header("", $hname);

	return lc($hv) eq "you stupid bot!";
}

sub process_new_articles {
	print STDERR "Processing new articles ...\n";

	&check_group;

	my ($msgid, $artn) = &select_first_new_article;
	my ($count, $interesting, $replied) = (0, 0, 0);

	local $SIG{ALRM} = sub {
		print STDERR "Current article: $artn $msgid  Processed: $interesting/$count\n";
		alarm $STATUS_INTERVAL;
	};
	alarm $STATUS_INTERVAL;

ART:	while (defined $artn) {
		next if exists $my_articles{$msgid};
		++$count;
		($my_articles{$msgid} = "QUIETED"), next if check_to_be_quiet();
		my $bcr = defined get_article_header("", "X-Bugs-Check-Ref");
		if ($bcr) {
			$bcr = get_article_header("", "References");
			if ($bcr) {
				my @refs = split(' ', $bcr);
				$bcr = pop @refs;
#				$bcr = undef if exists $my_articles{$bcr};
			}
			if ($bcr) {
				++$count;
				my @f = process_article($bcr, 2, $msgid);
				++$interesting if shift @f;
				++$replied if shift @f;
			}
		}
		my $bcm = defined get_article_header("", "X-Bugs-Check-Me");
#		unless ($bcm) {
#			my $refs = get_article_header("", "References");
#			next unless $refs;
#
#			my @refs = split(' ', $refs);
#			my $ref = pop @refs;
#			while (not exists $my_articles{$ref}) {
#				$ref = pop @refs;
#				next ART unless defined $ref;
#			}
#			next ART if $my_articles{$ref} =~ "REQ";
#		}
		$bcm = $bcm ? 1 : 0;
		my @f = process_article($artn, $bcm);
		++$interesting if shift @f;
		++$replied if shift @f;
	} continue {
		($msgid, $artn) = &select_next_article;
	}
	alarm 0;
	print STDERR "... finished: $count articles, $interesting processed, $replied replied\n";
}

sub fetch_article {
	my ($art) = @_;
	$art = "" unless defined $art;
	my $artx = "($GROUP:$last_article_seen)";
	$artx = $art if $art;

	get_article_header_wHEAD($art, "");
	unless (defined $last_article_id) {
		print STDERR "Article $artx cancelled before HEAD\n";
		return;
	}

	print $nntp_socket "BODY $art\r\n";
	my $l = &read_response;
	if ($l == 423) {
		print STDERR "Article $artx cancelled before BODY\n";
		return;
	}
	nntp_conversation_fail("Invalid BODY response") unless $l == 222;
	my @body = ();

	while (defined ($l = &read_server_line)) {
		push @body, $l;
	}

	my $hdrs = { %last_article_headers };
	$hdrs->{BODY} = \@body;
	return $hdrs;
}

sub choose_enum_trailing {
	my ($num, $t1, $t2, $t5) = @_;

	return $t1 if $num == 1;
	$num = $num % 100;
	return $t5 if int($num / 10) == 1;
	$num = $num % 10;
	return $t2 if $num >= 2 && $num <= 4;
	return $t5;
}

sub expand_error_line {
	my ($error, $line, @params) = @_;

	my $param = @params;
	foreach (reverse @params) {
		$line =~ s/\$$param/$_/g;
		--$param;
	}
	while ($line =~ m/\$\[(.*?)]/) {
		my $enum = $1;
		my @data = split(':', $enum);
		unless ($data[0] =~ m/^[1-9]+$/) {
			die "No configvar '$data[0]' in msg '$error'"
				unless exists $configfile_vars{$data[0]}
				and ref($configfile_vars{$data[0]}) eq "SCALAR";
			$data[0] = ${$configfile_vars{$data[0]}};
		} else {
			die "No param #$data[0] in msg '$error'"
				unless exists $params[$data[0]-1];
			$data[0] = $params[$data[0]-1];
		}
		my $subst = choose_enum_trailing(@data);
		$line =~ s/\$\[$enum]/$subst/g;
	}
	while ($line =~ m/\$\{(.*?)}/) {
		my $var = $1;
		die "No configvar '$var' in msg '$error'"
			unless exists $configfile_vars{$var}
			and ref($configfile_vars{$var}) eq "SCALAR";
		my $val = ${$configfile_vars{$var}};
		$line =~ s/\$\{$var}/$val/g;
	}
	return $line;
}

sub report_error {
	my ($article, $line, $error, @err_params) = @_;
	die "Undefined error: '$error' from " . caller unless exists $error_info{$error};
	my $err = $error_info{$error};

	if (exists $article->{ERROR_HEADER_SUB}) {
		my $ff = $article->{ERROR_HEADER_SUB};
		delete $article->{ERROR_HEADER_SUB};	# coby sie nie zapetlilo
		&$ff;
	}

	my $error_heading = ($err->[0] >= 0) ? $error_heading[$err->[0]] . " " : "";
	my $clear_head = 1;
	my $line_text = ($error_heading and $line) ? "$LINE_HEAD $line: " : "";

	foreach (@$err) {
		--$clear_head, next if $clear_head;

		my $line = $error_heading . $line_text . expand_error_line($error, $_, @err_params);
		$error_heading = ' ' x length($error_heading);
		$line_text = "";
		while (length $line > $LINELEN_LIMIT) {
			my $begin = $line;
			my $last_space = rindex $begin, ' ', $LINELEN_LIMIT;
			$last_space = index $begin, ' ', $LINELEN_LIMIT if $last_space < length($error_heading);
			substr($begin, $last_space, length($begin) - $last_space, '') if $last_space > 0;
			push @{$article->{REPLY}}, $begin;
			substr $line, 0, length($begin)+1, $error_heading;
		}
		push @{$article->{REPLY}}, $line;
	}

	++$article->{"X-Bugs-Found"} if $err->[0] > 0;
}

our %valid_mime_headers = (
	"content-type" => 1,
	"content-transfer-encoding" => 1,
	"content-id" => 1,
	"content-disposition" => 1,
	"content-location" => 1
);

$error_info{"MIME: no MIME-Version"} = [ 2,
	"W Twojej wiadomości są nagłówki MIME ale brakuje nagłówka MIME-Version.",
	"Sprawdz, czy na pewno masz włączone wysyłanie wiadomości w formacie MIME."
];
$error_info{"MIME: version != 1.0"} = [ 2,
	"Wersja MIME \"\$1\" to nie \"1.0\". Takiej wersji nie ma!"
];
$error_info{"MIME: part has headers only"} = [ 3,
	"Fragment \$1 wiadomości ma same nagłówki!"
];
$error_info{"MIME: duplicated header"} = [ 2,
	"Nagłówek \"\$2\" jest powtórzony w fragmencie \$1 wiadomości."
];
$error_info{"MIME: invalid header line"} = [ 3,
	"Nieprawidłowa linia nagłówka w fragmencie \$1."
];
$error_info{"MIME: non-standard header"} = [ 1,
	"Nieznany nagłówek MIME fragmentu \$1: \"\$2\""
];
$error_info{"MIME: no header to continue"} = [ 3,
	"Linia kontynuacji bez poprzedzającego nagłówka w fragmencie \$1."
];
$error_info{"MIME: unterminated multipart"} = [ 3,
	"Fragment \$1 wiadomości nie został poprawnie zakończony."
];
$error_info{"MIME: no Content-Type"} = [ 3,
	"W fragmencie \$1 wiadomości brakuje nagłówka \"Content-Type\"."
];

# RFC 1521 (not checked)
sub split_mime_message {
	my ($article) = @_;

	$article->{MIME} = 0;
	return unless exists $article->{'content-type'};
	if (exists $article->{'mime-version'}) {
		my $mime_version = $article->{'mime-version'};
		report_error($article, 0, "MIME: version != 1.0", $mime_version)
			if $mime_version ne "1.0";
	} else {
		report_error($article, 0, "MIME: no MIME-Version");
	}

	my @pre_head = ("Content-Type: " . $article->{'content-type'});
	push @pre_head, "Content-Transfer-Encoding: " . $article->{'content-transfer-encoding'}
		if exists $article->{'content-transfer-encoding'};
	push @pre_head, "";

	my $line = - scalar @pre_head;
	my $multipart_type = "toplevel";
	my $boundary = undef;
	my $parts = undef;
	my @part_stack = ();
	my @frag_no = (1);

	my $state_body = 0;
	my @part_body = ();
	my %part_head = ();
	my $last_head = "";

	foreach (@pre_head, @{$article->{BODY}}) {
		++$line;
		if (defined $boundary and ($_ eq $boundary or $_ eq $boundary . "--")) {
			# rozdzielnik czesci
			unless ($state_body) {	# naglówki sie nie skonczyly ...
				report_error($article, $line, "MIME: part has headers only");
			} elsif ($state_body == 1) {	# poprawna czesc
				push @$parts, { %part_head }, [ @part_body ];
				@part_body = ();
				%part_head = ();
			}
			if ($_ eq $boundary) {
				$state_body = 0;
			} else {	# koniec czesci
				$state_body = -1;
				my $nested_parts = $parts;
				my $pop = pop @part_stack;
				($boundary, $multipart_type, $line, $parts) = @$pop;
				push @$parts, $nested_parts;
				pop @frag_no;
			}
			$last_head = "";
			next;
		}
		if ($state_body == 0) {	# naglówki
			unless ($_) {	# koniec naglówków
				$state_body = 1;
				$part_head{"X-Multipart-Relation"} = $multipart_type;
				$part_head{"X-Starting-Line"} = $line;

				unless (exists $part_head{'content-type'}) {
					report_error($article, $line, "MIME: no Content-Type",
						join('.', @frag_no));
				} elsif ($part_head{'content-type'} =~ m/^["]?multipart\/(.*?)["]?;.*boundary="(.*?)"/i) {
					# MIME multipart message
					push @part_stack, [ $boundary, $multipart_type, $line, $parts ];
					$multipart_type = lc $1;
					$boundary = "--$2";
					$parts = [];
					$state_body = -1;
					push @frag_no, 1;
					%part_head = ();
					@part_body = ();
				} else {
					$part_head{'content-type'} .= ';';
				}
				next;
			}
			if (s/^\s+//) {	# kontynuacja naglówka
				if ($last_head) {
					$part_head{$last_head} .= "\t$_";
				} else {
					report_error($article, $line, "MIME: no header to continue",
						join('.', @frag_no));
				}
			} else {	# nowy naglówek
				if (m/^([-A-Za-z0-9]+):\s+(.*)$/) {
					$last_head = lc $1;
					if (exists $part_head{$last_head}) {
						report_error($article, $line, "MIME: duplicated header",
							join('.', @frag_no), $1);
					} elsif (not exists $valid_mime_headers{$last_head}) {
						report_error($article, $line, "MIME: non-standard header",
							join('.', @frag_no), $1);
					}
					$part_head{$last_head} = $2;
				} else {
					report_error($article, $line, "MIME: invalid header line",
						join('.', @frag_no));
				}
			}
		} else {	# czesc wlasciwa (z danymi)
			push @part_body, $_;
		}
	}

	if ($state_body == 1) {	# dokonczenie czesci
		# albo nie bylo multipart/* albo którys byl niedokonczony
		push @$parts, { %part_head }, [ @part_body ];
	}

	while (defined $boundary) {	# niedokonczone multipart-y
		my $nested_parts = $parts;
		my $pop = pop @part_stack;
		($boundary, $multipart_type, $line, $parts) = @$pop;
		push @$parts, $nested_parts;
		pop @frag_no;
		report_error($article, $line, "MIME: unterminated multipart", join('.', @frag_no));
	}

	$article->{BODY} = $parts;
	$article->{MIME} = 1;
}

my $BASE64_TABLE = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
my %BASE64_HASH;
$BASE64_HASH{substr($BASE64_TABLE, $_, 1)} = $_ foreach (0 .. 63);

# RFC 1521 - BASE64
sub decode_base64 {
	my @s;
	foreach my $s (@_) {
		my @block = ();
		my $data = '';
		foreach (split('', "$s")) {
			unless (exists $BASE64_HASH{$_}) {
				last if $_ eq '=';
				next;
			}
			push @block, $BASE64_HASH{$_};
			if (@block == 4) {
				$data .= chr(($block[0] << 2) | ($block[1] >> 4));
				$data .= chr(($block[1] << 4) & 0xFF | ($block[2] >> 2));
				$data .= chr(($block[2] << 6) & 0xFF | $block[3]);
				@block = ();
			}
		}
		if (@block > 0) {
			$data .= chr(($block[0] << 2) | ($block[1] >> 4))
				if @block >= 2;
			$data .= chr(($block[1] << 4) & 0xFF | ($block[2] >> 2))
				if @block == 3;
		}
		push @s, $data;
	}
	return @s if wantarray;
	return $s[0];
}

sub mime_charset {
	my @ret = ();
	foreach (@_) {
		$_ = lc $_;
		s/^(iso|utf)([^-])/$1-$2/;
		push @ret, $_;
	}
	return @ret;
}

sub decode_mime_encoded_word {
	my ($cset, $q, $string) = @_;
	($cset, $q) = (mime_charset($cset), uc $q);
	if ($q eq "Q") {	# RFC 1522 rozdzial 4.2.
		my @str = split(/(=[[:xdigit:]]{2})/, $string);
		$string = '';
		my $qchar = 0;
		foreach (@str) {
			if ($qchar) {
				$string .= chr hex substr $_, 1, 2;
			} else {
				$string .= $_;
			}
			$qchar = 1 - $qchar;
		}
		$string =~ tr/_/ /;	# spacje
	} elsif ($q eq "B") {
		$string = decode_base64($string);
	}
	return [ $string, $cset, $q, join("?", '=', @_, '=') ];
}

my $Qencode_chars = "_=?";

sub mime_qencode {
	my $cset = shift;
	my @result = ();
	my $maxline = 75 - 7 - length($cset);

	foreach my $entry (@_) {
		my $line = '';
		foreach (split('', $entry)) {
			next if ord($_) < 0x20;
			if (index($Qencode_chars, $_) >= 0 or ord >= 0x80) {
				if (length($line) + 3 > $maxline) {
					push @result, "=?$cset?Q?$line?=";
					$line = '';
				}
				$line .= sprintf "=\%02X", ord;
			} else {
				if (length($line) + 1 > $maxline) {
					push @result, "=?$cset?Q?$line?=";
					$line = '';
				}
				$line .= ($_ eq ' ') ? '_' : $_;
			}
		}
		push @result, "=?$cset?Q?$line?=";
	}
	return $result[0] unless wantarray;
	return @result;
}

# RFC 1522
sub decode_mime_quoted_string {
	my ($string) = @_;
	my @line = split(' ', $string);
	my @str = ('');
	my $lasteword = 0;

	foreach (@line) {
			# RFC1522 rozdzial 2.
		unless (length($_) <= 75 and m/^=\?([^][ ()<>@,;:"\/?.=]+)\?([^][ ()<>@,;:"\/?.=]+)\?([^ ?]+)\?=/) {
			push @str, ' ' if $lasteword;
			$lasteword = 0;
			$str[$#str] .= "$_ ";
			next;
		}
		push @str, decode_mime_encoded_word($1, $2, $3);
		$lasteword = 1;
	}
	chop $str[$#str] unless $lasteword;
	return @str;
}

sub decode_mime_quoted_header {
	my ($article, $header, $quiet) = @_;
	return ($article->{$header}) unless $article->{MIME};
	return decode_mime_quoted_string($article->{$header});
}

sub parse_from_header {
	my ($article) = @_;
	my $from_line = $article->{"from"};

	my ($name, $addr) = ();
	($name, $addr) = ($2, $1) if $from_line =~ m/^(.*?)\s+\((.*)\)$/;
	($name, $addr) = ($1, $2) if $from_line =~ m/^(.*)\s+<(.*?)>$/;
	return $from_line unless defined $name;
	return $addr unless wantarray and $name ne "";
	$name =~ s/^['"](.*)['"]$/$1/;
	return ($addr, [ $name ], $name, 'us-ascii') unless $article->{MIME};

	my @from = decode_mime_quoted_string($name);
	my $cset = undef;
	$name = '';
	foreach (@from) {
		unless (ref $_) {
			$name .= $_;
			next;
		}
		$name .= $_->[0];
		return ($addr, \@from, undef)
			if defined $cset and $_->[1] ne $cset;
		$cset = $_->[1];
	}
	$cset = 'us-ascii' unless defined $cset;
	return ($addr, \@from, $name, $cset);
}

sub make_citation {
	my @result = ();
	my ($start_blanks, $end_blanks, $double_blanks, $sigdashes) = (0, 0, 0, 0);
	my ($blanks, $lines, $out_line, $state) = (0, 0, 1, 1);

	foreach (@_) {
		++$lines;
		if ($_ eq "-- " and not $sigdashes) {
			$sigdashes = -1;
			$state = 0;
		}
		s/\s+$//;
		if ($state) {
			++$start_blanks, next unless $_;
			--$state;
		}
		if ($_) {
			if ($end_blanks) {
				if ($end_blanks > 1) { #FIXME
					my $tr1 = choose_enum_trailing($end_blanks, "a", "e", "ych");
					my $tr2 = choose_enum_trailing($end_blanks, "a", "e", "i");
					push @result, "[$end_blanks pust$tr1 lini$tr2]";
				} else {
					push @result, ">";
				}
				++$out_line;
			}
			push @result, "> $_";
			$end_blanks = 0;
			$sigdashes = $out_line if $sigdashes < 0;
			++$out_line;
		} else {
			++$double_blanks if $end_blanks;
			++$end_blanks;
			++$blanks;
		}
	}
	$blanks += $start_blanks;
	$double_blanks -= $end_blanks - 1 if $end_blanks;

	my $stats = {
		start_blanks => $start_blanks,
		end_blanks => $end_blanks,
		double_blanks => $double_blanks,
		total_blanks => $blanks,
		sigdashes => $sigdashes - 1,
		lines => $lines
	};
	return $stats, @result;
}

$error_info{"HEADERS: Subject"} = [ -1,
	"Temat wiadomości:"
];
$error_info{"HEADERS: no Subject"} = [ 3,
	"Brak tematu wiadomości (nagłówka 'Subject')!"
];
$error_info{"SUBJECT: empty"} = [ 3,
	"Temat Twojej wiadomości jest pusty!"
];
$error_info{"SUBJECT: subject with \"Odp:\" instead of \"Re:\""} = [ 2,
	"Twój czytnik wstawia \"\$1\" zamiast \"Re:\" przy odpowiedzi."
];
$error_info{"SUBJECT: \"Re:\" not removed"} = [ 2,
	"Twój czytnik nie usuwa dopiska \"Re:\" sprzed poprzedniego tematu "
.	"przy odpowiedzi."
];
$error_info{"SUBJECT: too long"} = [ 3,
	"Temat to nie miejsce na treść wiadomości, a na jej temat (czyżby to "
.	"nie było na tyle oczywiste ?). \$1 znak\$[1::i:ów] w zupełności "
.	"wystarcza do określenia tematu."
];

### TEST ### temat wiadomosci
sub test_subject {
	my ($article) = @_;

	unless (exists $article->{"subject"}) {
		report_error($article, 0, "HEADERS: no Subject");
		return;
	}

	my $subject = $article->{"subject"};
	my @subject;
	if ($article->{MIME}) {
		@subject = decode_mime_quoted_header($article, "subject");
		$subject = join('', map { ref($_) ? $_->[0] : $_ } @subject);
	}

	my $savesubject = $subject;
	$article->{ERROR_HEADER_SUB} = sub {
		report_error($article, 0, "HEADERS: Subject");
		my ($stats, @cite) = make_citation("Subject: $savesubject");
		push @{$article->{REPLY}}, @cite, "";
	};

	if ($subject =~ m/^(odp:)/i) {
		report_error($article, 0, "SUBJECT: subject with \"Odp:\" instead of \"Re:\"", $1);
		$subject =~ s/^odp:\s*//i;
	} else {
		$subject =~ s/^Re:\s*//i;
	}
	report_error($article, 0, "SUBJECT: \"Re:\" not removed")
		if $subject =~ s/^Re:\s*//i;

	if (length($subject) > $SUBJECT_MAXLEN) {
		report_error($article, 0, "SUBJECT: too long", $SUBJECT_MAXLEN, length $subject);
		$subject = mime_qencode($CHARSET, $LONG_SUBJECT_SUBST);
	} elsif ($article->{MIME}) {
		for(;;) {
			my $s = shift(@subject);
			last unless defined $s;
			my $v = $s;
			$v = $v->[0] if ref $v;

			$v =~ s/^((re|odp):\s+)+//i;
			next if $v eq '';

			$s->[0] = $v if ref $s;
			$s = $v unless ref $s;

			unshift @subject, $s;
			last;
		}
		$subject = '';
		foreach (@subject) {
			if (ref $_) {
				$subject .= join(' ', '', mime_qencode($_->[1], $_->[0]), '');
			} else {
				$subject .= $_;
			}
		}
		@subject = split(/\s+/, $subject);
		shift @subject if $subject[0] eq '';
		$subject = '';
		my $len = 0;
		foreach (@subject) {
			if ($len and $len + length($_) > 76) {
				$subject .= "\r\n\t";
				$len = 0;
			}
			$subject .= "$_ ";
			$len += length($_) + 1;
		}
		chop $subject;
	}
	if ($subject eq "") {
		report_error($article, 0, "SUBJECT: empty");
		$article->{"Subject"} = mime_qencode($CHARSET, $EMPTY_SUBJECT_SUBST);
	} else {
		$article->{"Subject"} = $subject;
	}

	delete $article->{ERROR_HEADER_SUB};
}

$error_info{"HEADERS: Followup-To"} = [ -1,
	"Nagłówek Followup-To:"
];
$error_info{"FUT: poster"} = [ 0,
	"'Followup-To:' Masz za mało spamu w skrzynce pocztowej?"
];
$error_info{"FUT: same group"} = [ 0,
	"'Followup-To:' Przecież i tak piszę na tą grupę."
];
$error_info{"FUT: other group"} = [ 0,
	"'Followup-To:' Sam sobie pobiegaj!  - [Z dedykacją dla Skrypka. :]"
];
$error_info{"MIME: attachments present"} = [ 3,
	"Twoja wiadomość ma załączniki!",
	"Na większości grup wysyłanie załączników nie jest mile widziane."
];
$error_info{"MIME: not enabled"} = [ 1,
	"Twoja wiadomość nie ma nagłówków MIME (brakuje Content-Type). Włącz format "
.	"MIME dla wiadomości newsowych."
];
$error_info{"MIME: not used"} = [ 3,
	"Twoja wiadomość nie ma nagłówka \"Content-Type\", a mimo to znalazłem "
.	"w niej litery spoza zestawu US-ASCII. Czytniki nie wiedzą przez to jakiego "
.	"zestawu znaków użyć i polegają na domyślnych ustawieniach. Przejrzyj "
.	"konfigurację swojego czytnika i ustaw kodowanie na \"\${PREFER_CHARSET}\".",
	"Rozwiązaniem może być także włączenie formatu MIME dla wiadomości newsowych."
];
$error_info{"BOT: be quiet"} = [ 0,
	"Autor wiadomości chciał żebym siedział cicho."
];

sub test_headers {
	my ($article) = @_;

### TEST ### naglówek 'Followup-To'

	if (exists $article->{"followup-to"}) {
		my $fut = $article->{"followup-to"};
		$article->{ERROR_HEADER_SUB} = sub {
			report_error($article, 0, "HEADERS: Followup-To");
			my ($stats, @cite) = make_citation("Followup-To: $fut");
			push @{$article->{REPLY}}, @cite, "";
		};
		if ($fut eq 'poster') {
			report_error($article, 0, "FUT: poster");
			push @{$article->{REPLY}}, "";
		} elsif ($fut ne $GROUP) {
			report_error($article, 0, "FUT: other group");
			push @{$article->{REPLY}}, "";
#		} else {
#			report_error($article, 0, "FUT: same group");
		}
		delete $article->{ERROR_HEADER_SUB};
	}

### TEST ### MIME

	if ($article->{MIME}) {
		report_error($article, 0, "MIME: attachments present")
			if ref($article->{BODY}->[0]) eq "ARRAY" and $YELL_ON_ATTACHMENTS;
	} else {
		report_error($article, 0, 
			test_8bit($article->{BODY})
				? "MIME: not used"
				: "MIME: not enabled"
		);
	}

### TEST ### X-Bugs-Be-Quiet

	report_error($article, 0, "BOT: be quiet")
		if check_to_be_quiet($article);
}

sub flatten_multiparts {
	my ($atn_ref, $parts) = @_;
	my @ret = ();
	my $next_body = 0;

	push @$atn_ref, 0;

	foreach (@$parts) {
		if ($next_body) {
			$next_body = 0;
			push @ret, $_;
			next;
		}
		++$atn_ref->[$#$atn_ref];
		if (ref($_) eq "ARRAY") {
			push @ret, flatten_multiparts($atn_ref, $_);
		} else {
			$_->{"Part-Number"} = join('.', @$atn_ref);
			push @ret, $_;
			$next_body = 1;
		}
	}

	pop @$atn_ref;
	return @ret;
}

$error_info{"MIME: charset == us-ascii"} = [ 3,
	"Twoje kodowanie to \"us-ascii\", a mimo to w Twojej wiadomości znalazłem "
.	"znaki o kodach spoza tego zestawu!"
];
$error_info{"MIME: no 8-bit test"} = [ 1,
	"W Twojej wiadomości nie pojawiły się znaki spoza zestawu US-ASCII więc "
.	"nie mogłem sprawdzić jak Twój czytnik sobie z nimi radzi. Wyślij wiadomość "
.	"z polskimi literami."
];
$error_info{"MIME: wrong charset"} = [ 3,
	"Twoje kodowanie to \"\$1\". Zmień je na \"\${PREFER_CHARSET}\" lub \"UTF-8\"!"
];
$error_info{"MIME: wrong charset UTF-8"} = [ 3,
	"Twoje kodowanie to \"\$1\". Zmień je na \"UTF-8\"!"
];
$error_info{"MIME: HTML alternative"} = [ 3,
	"NIE wysyłaj w HTML-u!!!",
	"Po prostu NIE wysyłaj wiadomości w HTML-u."
];
$error_info{"MIME: no text/plain article"} = [ 3,
	"Brakuje artykułu właściwego (nie ma fragmentu typu text/plain)."
];
$error_info{"MIME: no charset"} = [ 3,
	"W nagłówku \"Content-Type\" brakuje wpisu \"charset\"!"
];

sub test_attachments {
	my ($article) = @_;
	return unless $article->{MIME};

	my @atn = ();
	my @parts = flatten_multiparts(\@atn, $article->{BODY});
	$article->{FLAT_BODY} = \@parts;
	$article->{ARTICLE_PART} = undef;

	foreach (0 .. (@parts / 2) - 1) {
		my $i = $_ * 2;
		next unless $parts[$i]->{'content-type'} =~ m/^["]?text\/(.*?)["]?;/i;
		my $text_type = lc $1;
		my $charset = "";
		$charset = lc $1 if $parts[$i]->{'content-type'} =~ m/charset=(.*?);/i;
		$charset =~ s/^"(.*)"$/$1/;

		unless ($charset) {
			report_error($article, $parts[$i]->{'X-Starting-Line'}, "MIME: no charset");
		} elsif ($charset eq "us-ascii") {
			report_error($article, $parts[$i]->{'X-Starting-Line'},
				test_8bit($parts[$i+1]) ? "MIME: charset == us-ascii" : "MIME: no 8-bit test");
		} elsif ($charset ne $PREFER_CHARSET and $charset ne 'utf-8') {
			report_error($article, $parts[$i]->{'X-Starting-Line'},
				"MIME: wrong charset" . ($PREFER_CHARSET eq 'utf-8' ? ' UTF-8' : ''), $charset);
		}
		report_error($article, $parts[$i]->{'X-Starting-Line'}, "MIME: HTML alternative")
			if $text_type eq 'html' and $parts[$i]->{'X-Multipart-Relation'} eq "alternative";
		$article->{ARTICLE_PART} = $i + 1
			if $text_type eq "plain" and not defined $article->{ARTICLE_PART};
	}

	report_error($article, 0, "MIME: no text/plain article")
		unless defined $article->{ARTICLE_PART};
}

sub test_8bit {
	my ($body) = @_;

	foreach my $l (@$body) {
		foreach (split(//, $l)) {
			return 1 if (ord > 127);
		}
	}

	return 0;
}

$error_info{"BODY: second sigdashes"} = [ 1,
	"W Twojej wiadomości znalazłem kolejny ogranicznik sygnaturki. Poprzedni"
.	" jest w linii \$1. Większość czytników obcina odpowiedzi zaraz przed"
.	" pierwszym znacznikiem!"
];
$error_info{"BODY: sigdashes w/o space"} = [ 3,
	"Twój czytnik zjada spację na koncu ogranicznika sygnaturki. Jeśli to OE,"
.	" to da się to naprawić odpowiednim patchem (wg Skrypka OE naprawia"
.	" IE6/SP1+Q331923). W każdym przypadku da się zainstalować program"
.	" \"OE-Firewall\", który zajmie się wysyłanymi postami i będzie doklejał"
.	" poprawne sygnaturki."
];
$error_info{"BODY: malformed sigdashes"} = [ 3,
	"Twój czytnik stawia jakis dziwny znak zamiast spacji po dwóch minusach"
.	" ogranicznika sygnaturki lub zamiast tej spacji stawia '=20' (w kodowaniu"
.	" innym niz 'quoted-printable') lub '%20'."
];
$error_info{"BODY: empty sig"} = [ 1,
	"Twoja sygnaturka jest pusta!!!"
];
$error_info{"BODY: junk after sig"} = [ 3,
	"Sygnaturka powinna być OSTATNIM elementem wiadomości. Powtarzaj za mna:",
	"*Tniemy Cytaty I Odpowiadamy Pod Spodem*"
];
$error_info{"BODY: sig too long"} = [ 2,
	"Sygnaturka nie powinna mieć więcej niż \${SIGLINES_LIMIT}"
.	" lini\$[SIGLINES_LIMIT:ę:e:i], a Twoja ma ich aż \$1 !"
];
$error_info{"BODY: empty"} = [ 3,
	"Twoja wiadomość jest pusta ! Treść wiadomości powinna się znaleźć"
.	" w polu 'Treść wiadomości' (czy to takie dziwne ???)."
];
$error_info{"BODY: citation at end"} = [ 3,
	"Powtarzaj aż do zrozumienia:",
	"*Tniemy Cytaty I Odpowiadamy Pod Spodem*!"
];
$error_info{"BODY: only citation"} = [ 3,
	"Sam cytat i nic więcej. Zapamiętaj:"
.	" Tniemy Cytaty I Odpowiadamy Pod Spodem!"
];
$error_info{"BODY: too long lines"} = [ 2,
	"Przed tą linią znalazłem \$1 lini\$[1:ę:e:i] dłuższ\$[1:ą:e:ych] niż"
.	" \${LINELEN_MAX} znak\$[LINELEN_MAX::i:ów], przez co dla dużej części"
.	" czytających Twoja wiadomość jest mało czytelna!"
];
$error_info{"BODY: too long answer lines"} = [ 1,
	"Przed tą linią znalazłem \$1 lini\$[1:ę:e:i] dłuższ\$[1:ą:e:ych] niż"
.	" \${LINELEN_LIMIT} znak\$[LINELEN_LIMIT::i:ów], przez co cytującym"
.	" Ciebie osobom znacznie utrudniasz życie."
];

sub test_body {
	my ($article, $body) = @_;

	if (@{$article->{REPLY}}) {
		$article->{ERROR_HEADER_SUB} = sub {
			push @{$article->{REPLY}}, "";
		};
	}

	my $qp_space = ($article->{MIME}
		and exists $article->{"content-transfer-encoding"}
		and lc($article->{"content-transfer-encoding"}) eq "quoted-printable");
	my @form = ();
	my $longlines = 0;
	my $sigline = 0;
	my $state = "";
	my $line = 0;
	foreach (@$body) {	# zaznaczenie fragmentów tekstu
		++$line;
		s/=20/ /g if $qp_space;
		++$longlines if length($_) > $LINELEN_MAX;

		if (m/^[ ]*(([A-Za-z0-9]*[>])|[:>|])/) {	# cytat
			if ($state ne "CITE") {
				push @form, $line, "CITE";
				$state = "CITE";
			}
		} elsif ($_ eq "--") {	# zepsuty ogranicznik
			if ($sigline >= 0) {
				push @form, $line, "--";
				$state = "";
				$sigline = $line;
			} elsif ($state ne "TEXT") {
				push @form, $line, "TEXT";
				$state = "TEXT";
			}
		} elsif ($_ eq "-- ") {	# ogranicznik poprawny
			push @form, $line, "-- ";
			$state = "";
			report_error($article, $line, "BODY: second sigdashes", -$sigline)
				if $sigline < 0;
			$sigline = -$line;
		} elsif (m/^--.$/ or $_ eq "--=20" or $_ eq "--%20") {	# ogranicznik dziwny (=zly)
			if ($sigline >= 0) {
				push @form, $line, "--?";
				$state = "";
				$sigline = $line;
			} elsif ($state ne "TEXT") {
				push @form, $line, "TEXT";
				$state = "TEXT";
			}
		} elsif ($_) {	# niepuste linie
			if ($state ne "TEXT") {
				push @form, $line, "TEXT";
				$state = "TEXT";
			}
		}
	}

	$line = 0;
	my $own_longlines = 0;
	my $i = 0;
	$state = "";
	foreach(@$body) {
		++$line;
		last if $line == abs $sigline;
		++$i, ($state = $form[$i++])
			if $i < @form && $line == $form[$i];

		next if $state ne "TEXT";
		++$own_longlines if length($_) > $LINELEN_LIMIT;
	}

	report_error($article, $line, "BODY: too long answer lines", $own_longlines)
		if $own_longlines;
	report_error($article, scalar @$body, "BODY: too long lines", $longlines)
		if $longlines;

	if ($sigline) {	# sygnaturka jest
		$sigline = abs $sigline;
		# pozostawienie tylko ostatniego znacznika sygnaturki
		for($line = 0; $line < @form; $line += 2) {
			last if $form[$line] == $sigline;	# za ostatnim na pewno nie ma
			if (substr($form[$line+1], 0, 2) eq '--') {
				if ($line and $form[$line-1] eq "TEXT") {
					splice @form, $line, 2;
					redo;
				}
				if ($line + 2 < @form and $form[$line+3] eq "TEXT") {
					splice @form, $line + 1, 2;
				} else {
					$form[$line+1] = "TEXT";
				}
			}
		}

		# zly ogranicznik
		report_error($article, $sigline, ($body->[$sigline-1] eq "--")
			? "BODY: sigdashes w/o space" : "BODY: malformed sigdashes")
			if $body->[$sigline-1] ne "-- ";

		$line += 2;
		if ($line >= @form) {	# tylko ogranicznik
			report_error($article, $sigline, "BODY: empty sig");
		} elsif ($form[$line+1] eq "TEXT") {	# sygnaturka jest
			my $sigend;
			$line += 2;
			if ($line < @form) {	# jest tez cos 'extra'
				report_error($article, $form[$line], "BODY: junk after sig");
				$sigend = $form[$line] - 1;
			} else {
				$sigend = scalar @$body;
			}
			--$sigend if $body->[$sigend-1] eq "";	# jedna pusta linia na koncu
			my $siglen = $sigend - $sigline;	# nie dodajemy 1 bo nie liczymy minusów
			if ($SIG_IGNORE_1EMPTY and $siglen == $SIGLINES_LIMIT + 1) {
				# jedna pusta linie ze srodka lub konca siga mozemy darowac
				foreach(@$body[($sigline+1) .. ($sigend-1)]) {
					next if $_ ne '';
					--$siglen;
					last;
				}
			}

			report_error($article, $sigend, "BODY: sig too long", $siglen)
				if $siglen > $SIGLINES_LIMIT;
		}
	} else {	# sygnaturki nie ma
		unless (@form) {	# pustka ...
			report_error($article, 1, "BODY: empty");
		} else {
			# cytat na koncu wiadomosci
			report_error($article, $form[$#form-1], (@form > 2)
				? "BODY: citation at end" : "BODY: only citation")
				if $form[$#form] eq "CITE";
		}
	}

	delete $article->{ERROR_HEADER_SUB};
}

$error_info{"INFO: orig author"} = [ -1,
	"Użytkowniku podpisujący się jako \"\$3\":"
];
$error_info{"INFO: orig author addr only"} = [ -1,
	"Użytkowniku wysyłający z adresu \"\$2\":"
];
$error_info{"INFO: orig author other charset"} = [ -1,
	"Użytkowniku podpisujący się nieczytelnie (\$2):"
];
$error_info{"INFO: orig author multi charset"} = [ -1,
	"Użytkowniku podpisujący się całkiem nieczytelnie (\$2):"
];
$error_info{"INFO: no bugs"} = [ -1,
	"Nie znalazłem żadnych błędów w Twojej wiadomości.  :-)",
	"(Co wcale nie oznacza, że na pewno żadnych nie ma.)"
];
$error_info{"INFO: bugs count"} = [ -1,
	"Znalazłem *\$1* bł\$[1:ąd:ędy:ędów] w Twojej wiadomości."
];
$error_info{"INFO: severity signs"} = [ -1,
	"Wypełnienie pola \"[   ]\" oznacza powagę błędu w skali od 0 do 3."
];

sub test_article {
	my ($article) = @_;

	$article->{"X-Bugs-Found"} = 0;
	$article->{REPLY} = [];
	my $msgid = $article->{"message-id"};

	split_mime_message($article);
	test_subject($article);
	test_headers($article);
	test_attachments($article);

	my $body = $article->{BODY};
	if ($article->{MIME}) {
		if (defined $article->{ARTICLE_PART}) {
			$body = $article->{FLAT_BODY}->[$article->{ARTICLE_PART}];
		} else {
			$body = undef;
		}
	}
	test_body($article, $body) if defined $body;

	my $tmpart = { REPLY => [] };
	my @from = parse_from_header($article);
	$article->{"FROM"} = $from[0];

	unless (defined $from[1]) {
		report_error($tmpart, 0, "INFO: orig author addr only", $msgid, $from[0]);
	} elsif (defined $from[2]) {
		report_error($tmpart, 0,
			($from[3] eq $CHARSET or $from[3] eq 'us-ascii')
				? "INFO: orig author" : "INFO: orig author other charset",
			$msgid, $from[0], $from[2], $from[3]);
	} else {	# not defined $from[2]
		report_error($tmpart, 0, "INFO: orig author multi charset", $msgid, $from[0]);
	}

	if ($article->{"X-Bugs-Found"}) {
		report_error($tmpart, 0, "INFO: bugs count", $article->{"X-Bugs-Found"});
	} else {
		report_error($tmpart, 0, "INFO: no bugs");
	}
	unshift @{$article->{REPLY}}, @{$tmpart->{REPLY}}, "";
	push @{$article->{REPLY}}, "";
	report_error($article, 0, "INFO: severity signs") if $article->{"X-Bugs-Found"};
}

sub cut_references {
	my ($refs) = @_;

	my $n = length $refs;
	my @refs = split(' ', $refs);
	while ($n > 900) {
		my $d = shift @refs;
		$n -= 1 + length($d);
	}

	return join(' ', @refs);
}

sub process_article {
	my ($art, $forced_check, $checker) = @_;
	my $article = fetch_article($art);
	return unless $article;

	test_article($article);

	my $msgid = $article->{"message-id"};
	my $author = $article->{"FROM"};

	my $new_author = not exists $known_people_bugs{$author};
	my $last_bugs = $known_people_bugs{$author};
	$known_people_bugs{$author} = $article->{"X-Bugs-Found"};

	my $posted = 0;
	if ($REPLY_ALWAYS or $new_author or $forced_check or $last_bugs or $article->{"X-Bugs-Found"}) {
		my @headers;
		push @headers, Subject => "Re: " . $article->{"Subject"};
		push @headers, References => ($article->{"references"} ?
			cut_references($article->{"references"} . " $msgid") : $msgid);
		push @headers, "X-Bugs-Last-Checked-ID" => $known_people_last_article{$author}
			unless $new_author;
		push @headers, "X-Bugs-Referenced-By" => $checker
			if defined $checker;
		push @headers, "X-Bugs-Found" => ($article->{"X-Bugs-Found"} ? $article->{"X-Bugs-Found"} : 0);

		--$last_article_seen;
		my $mymsgid = post_article(\@headers, $article->{REPLY});
		++$last_article_seen;
		$my_articles{$mymsgid} = ($forced_check ? "REQREPLY" : "MYREPLY");
		$my_articles{$msgid} =
			($forced_check ? ($forced_check == 1 ? "REQUEST" : "REFREQUEST") : "REPLIED");
		$posted = 1;
	} else {
		$my_articles{$msgid} = "UNREPLIED";
	}

	$known_people_last_article{$author} = $last_article_id;
	return (1, $posted);
}

if (@ARGV > 0 && $ARGV[0] eq "-C") {
	save_state("config", \%configfile_vars, "default configuration");
	exit 0;
}

print STDERR "$BOTNAME/$VERSION by mirQus, $CYEARS\n";
read_config("config");
unless (read_config("state")) {
	&connect_to_server;
	&check_group;
	$last_article_seen = $last_article;
	&disconnect unless $NNTP_PERSISTENT_CONNECTION;
}

if (@ARGV > 0 && $ARGV[0] eq "-A") {
	shift;
	&connect_to_server;
	my $msgid = post_article([ Subject => 'Sprawdzanie czytników inaczej zwanych newsreaderami' ], [
		'Wygląda na to, że wsio działa jak trzeba, albo jak trza nawet. ;)',
		'Bot jest ciągle w wersji BETA - działa, ale brakuje mu wielu testów',
		'poprawności postów. W miarę czasu i chęci będę je dodawał.', '',
		'A tymczasem sprawdzajcie się. :)',
	]);
	$my_articles{$msgid} = "SELFANNOUNCE";
	&disconnect;
	save_state("state", \%statefile_vars);
	exit 0;
}

my $sleep_sec = 0;

if (@ARGV > 1 && $ARGV[0] eq "-S") {
	shift;
	$sleep_sec = 0 + shift;
}

my $sig_handler = sub { $terminating = 1; print STDERR "Terminating ...\n"; };
$SIG{'TERM'} = $sig_handler;
$SIG{'INT'} = $sig_handler;

for(; not $terminating; sleep $sleep_sec) {
	print STDERR "Starting at ", scalar localtime, "\n";
	&connect_to_server;
	&process_new_articles;
	&prune_my_articles;
	save_state("state", \%statefile_vars);
	&disconnect unless $NNTP_PERSISTENT_CONNECTION;
	print STDERR "Finished at ", scalar localtime, "\n";
	last if $terminating or not $sleep_sec;
}

&disconnect if $nntp_socket;
exit 0;
