+#!/usr/bin/perl
+#
+# Automatic Article Checker
+# v1.6 Copyright (C) June 2, 1999 by Heinrich Schramm
+# mailto:heinrich@schramm.com
+#
+# converted to perl by Wilfried Klaebe <wk@orion.toppoint.de>
+# (not really converted, more or less rewritten in perl)
+#
+# modified & enhanced
+# by Thomas Hochstein <THochstein@gmx.de> since March/April 2000
+# (c) artchk.pl (mod.) January 06, 2001 by Thomas Hochstein
+#
+# _________ ATTENTION please! - This is still a BETA version! _________
+#
+# ------------------------------------------------------------------------------
+# 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 will need the following modules from CPAN:
+# - News::NNTPClient
+# - MIME::QuotedPrint
+# - MIME::Base64
+# (- Net::DNS)
+#
+# ------------------------------------------------------------------------------
+#
+# You will have to create an artchk.pl.ini / artchk.pl.rc file.
+# Please see readme.txt for details.
+#
+# Please use this program with care and sense of responsibility!
+# Thank you.
+#
+##################################################################
+
+###-### mark for temp. changes
+#-# 1.2.01g changes new in that version
+#-# {RKELLER} Contributed by Reiner Keller <keller@dlrg.de>
+
+use News::NNTPClient;
+use MIME::QuotedPrint;
+use MIME::Base64;
+use Net::DNS;
+use File::Basename; #-# {RKELLER}
+
+##### Constants
+$version = 'V 1.2.01k BETA'; # Stand: 2001-10-13
+$online = 0; # permanent connection to the net
+$serverresponse = "# NNTP:"; # intro for debugmsg (NNTP status response)
+$debugdiagmarker = "* ->"; # intro for debugmsg (diag{...} set)
+@roles = qw/abuse noc security
+ root sysop admin newsmaster
+ postmaster hostmaster usenet news webmaster www uucp ftp/;
+$hex_nibb = '[0-9a-fA-F]';
+$gt_hex_nibb = '[0-9A-F]';
+$lt_hex_nibb = '[0-9a-f]';
+$alpha_num = '[0-9a-zA-Z]';
+$lt_alpha_num = '[0-9a-z]';
+$gt_alpha_num = '[0-9A-Z]';
+# definitions from s-o-1036
+$r_unquoted_char_a = '[#$%&\'|*+{}~\-/0123456789=?A-Z^_`a-z]'; # correct definition (for mailaddress)
+$r_unquoted_word_a = "$r_unquoted_char_a+"; # correct definition (for mailaddress)
+$r_unquoted_char = '[#$%&\'|*+{}~\-/0123456789=?A-Z^_`a-z\x80-\xFF]'; # definition including \x80-\xFF (8bit)
+$r_unquoted_word = "$r_unquoted_char+"; # definition including \x80-\xFF (8bit)
+$r_quoted_char = '[!@,;:.\[\]#$%&\'|*+{}~\-/0123456789=?A-Z^_`a-z\x80-\xFF]'; # definition including \x80-\xFF (8bit)
+$r_quoted_word = "\"($r_quoted_char|\\s)+\""; # definition including \x80-\xFF (8bit)
+$r_paren_char = '["!@,;:.\[\]#$%&\'|*+{}~\-/0123456789=?A-Z^_`a-z\x80-\xFF]'; # definition including \x80-\xFF (8bit)
+$r_paren_phrase = "($r_paren_char|\\s)+"; # definition including \x80-\xFF (8bit)
+$r_plain_word = "$r_unquoted_word|$r_unquoted_word"; # definition including \x80-\xFF (8bit)
+$r_plain_phrase = "$r_plain_word(\\s+$r_plain_word)*"; # definition including \x80-\xFF (8bit)
+$r_address = "$r_unquoted_word_a(\\.$r_unquoted_word_a)*\@$r_unquoted_word_a(\\.$r_unquoted_word_a)*";
+
+##### Main program
+# get commandline parameters
+while (@ARGV) {
+ $f = shift;
+ if ($f =~ /^-d(.*)/) {
+ $debuglevel = $1;
+ } elsif ($f =~ /-(v+)/) {
+ $debuglevel = length($1);
+ } elsif ($f =~ /-p(.*)/) {
+ $pathtoini = $1;
+ } elsif ($f =~ /-n(.*)/) {
+ $ininame = $1;
+ if ($ininame=~/\.ini$/) {
+ $ininame=~s/(.*?)\.ini$/$1/;
+ };
+ } elsif ($f =~ /-c(.*)/) {
+ $checkpost = $1;
+ } elsif ($f =~ /^-l(.*)/) {
+ $logfile = $1;
+ if ($logfile =~/\.log$/) {
+ $logfile=~s/(.*?)\.log$/$1/;
+ };
+ } elsif ($f =~ /--log/) {
+ $logging = 1;
+ } elsif ($f =~ /--feedmode/) { #-# 1.2.01k
+ $feedmode = 1; #-# 1.2.01k
+ } elsif ($f =~ /--pedantic/) { #-# 1.2.01k
+ $pedantic = 1; #-# 1.2.01k
+ }
+};
+
+# set parameters to default, if necessary / exit, if disabled
+if (!defined($debuglevel)) {$debuglevel = 0};
+if (!defined($ininame)) {$ininame = basename ($0)}; #-# {RKELLER}
+exit (10) if (-e "$0.disabled"); # exit if "artchk.pl.disabled" exists
+exit (10) if (-e "$ininame.disabled"); # exit if ".disabled" exists
+if (!defined($pathtoini)) {
+ $pathtoini = dirname ($0).'/' #-# {RKELLER}
+} elsif ($pathtoini !~ /.*(\/|\\)$/) {
+ $pathtoini .= '/';
+}
+if (!defined($checkpost) or ($checkpost!~/<\S+\@\S+>/)) {$checkpost = 'no'};
+if (!defined($logfile)) {$logfile = "$ininame"};
+
+# open logfile
+if ($logging) {
+ open LOG, ">>$pathtoini$logfile.log" || die "Could not open $pathtoini$logfile.log for appending: $!";
+ if ($feedmode) { #-# 1.2.01k
+ select((select(LOG), $| = 1)[0]); # set autoflush
+ };
+};
+
+# print introduction
+op(10,"\n-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-\n\n");
+op(10,"This is artchk.pl (mod.) $version started on ".scalar(gmtime)." GMT.\n");
+op(0,"Send suggestions & comments to <artchk\@akallabeth.de>.\n\n");
+
+# read .rc-file / .ini-file / domains / killfile
+&readini;
+&readrcfile;
+&readdomains;
+if (-e "$killname.kill") {
+ open KILL, "<$pathtoini$killname.kill" || die "Could not open $pathtoini$killname.kill for reading: $!";
+ while (<KILL>) {
+ chomp;
+ s/#.+//; # drop comments
+ s/^\s+//; # drop whitespace before
+ s/\s+$//; # drop whitespace after
+ next unless length;
+ my ($key,$value) = split(/\s*=\s*/,$_,2); # header = regexp
+ push @{ $kill[scalar(@kill)] },lc($key),lc($value);
+ };
+ close KILL;
+};
+
+# print configuration
+op(1,"\nDebug-Level : $debuglevel\n");
+op(1, "Path to files : $pathtoini\n");
+op(1, "Filenames : $ininame.ini / $rcname.rc / $logfile.log\n");
+op(1, "Trigger 'check' : $trigger_check\n");
+op(1, "Trigger 'ignore' : $trigger_ignore\n");
+op(1, "Newsserver (read): $server $port\n");
+op(1, "Newsserver (post): $postingserver $postingport\n");
+if ($checkpost eq 'no') {
+ op(1, 'Groups to check :');
+ foreach $testgroup (@testgroups) {op(1, " $testgroup")};
+} else {
+ op(11, "Posting to check: $checkpost\n");
+};
+op(1, "\n\n");
+op(1, "---------- Starting connection procedure ----------\n");
+
+if ($feedmode) { #-# 1.2.01k ---->
+ until(eof(STDIN)){
+ $file=<STDIN>;
+ $file=~s/(\S*).*/$1/;
+ &feed_article($file); # will set $wholeheader, @header and $wholebody (global!)
+ &check_article;
+ }
+} else { #-# 1.2.01k <-----
+ # open server (for reading)
+ $readserver = &connectserver($server,$port,$s_user,$s_pass);
+
+ # open server (for posting), if specified
+ if ($postingserver ne '') { $postserver = &connectserver($postingserver,$postingport,$posts_user,$posts_pass) };
+
+ # main loop - check all postings in all groups
+ op(1,"---------- Starting checks ----------");
+
+ if ($checkpost eq 'no') {
+ foreach $testgroup (@testgroups) {
+ op(1,"\n---------- New group ----------");
+ op(1,"\nOpening group $testgroup ...");
+ # get low-/high-marks of $testgroup
+ if (!(($low, $high) = ($readserver->group($testgroup)))) {
+ op(13,"\n$serverresponse Error: " . $readserver->code . ' ' . $readserver->message . "Skipping group.\n");
+ op(0,"Error opening group $testgroup on $server.\n");
+ } else {
+ op(1," done.\n");
+ op(3,"$serverresponse".$readserver->code.' '.$readserver->message);
+ op(11,"\n$testgroup: $low ---> $high; first to be checked: $watermark{$testgroup}\n");
+ if ($watermark{$testgroup} > ($high + 2)) {
+ op(1,"! High watermark of group $testgroup is to low - resetting counter ...");
+ $watermark{$testgroup} = $high;
+ }
+ if ($watermark{$testgroup} > $low) {$low = $watermark{$testgroup}};
+ if ($watermark{$testgroup} > $high) {
+ op(1,"Nothing new to check in $testgroup ... terminating.\n");
+ } else {
+ op(1,'Starting checks, ');
+ if($auto{$testgroup}) {
+ op(1,"generating followups for any problem detected (auto-mode).\n");
+ }else{
+ op(1, "only generating followups if requested.\n");
+ }
+ }
+
+ # load posting
+ for ($doit = $low; $doit <= $high; $doit += 1) {
+ $togo=$high-$doit;
+ op(2,"Now getting: __> $doit <__ --- $togo to go ...\n");
+ &get_article($doit); # will set $wholeheader, @header and $wholebody (global!)
+ &check_article($testgroup,$auto{$testgroup});
+ };
+
+ # remmber last tested posting
+ $watermark{$testgroup} = $high + 1;
+
+ # rewrite .ini-file
+ op(1,"Rewriting .ini-file ... ");
+ &writeini;
+ op(1,"done.\n");
+ };
+ }
+ } else {
+ op(1,"\nNow getting: $checkpost\n");
+ &get_article($checkpost); # will set $wholeheader and $wholebody (global!)
+ &check_article('none',2);
+ }
+
+ op(1,"\n\n---------- Termination sequence ... ----------");
+ op(1,"\nartchk.pl (mod.) $version signing off.\n");
+ # close server and files
+ $readserver->quit;
+ if ($postingserver ne '') { $postserver->quit };
+};
+
+if ($logging) {
+ op(15,"$0 $version terminated successfully on ".scalar(gmtime)." GMT.\n");
+ close LOG;
+};
+op(0,"Program terminated on ".scalar(gmtime)." GMT.\n\n");
+op(0,"Thank you for using.\n");
+exit(0);
+
+################################################################
+# Main subroutines: get article / feed article / check article
+
+sub get_article {
+# load article via NNTP
+ my($doit)=@_;
+ my(@article,$lang);
+
+ # parse posting: first get headers ...
+ if (!(@article = $readserver->head($doit))) {
+ op(13,"\n$serverresponse Error: " . $readserver->code . ' ' . $readserver->message);
+ op(0,"Error reading header from $server.\n");
+ } else {
+ op(3,"$serverresponse".$readserver->code.' '.$readserver->message);
+ };
+ # split @article and add all lines to $wholeheader
+ @header = @article; # @header is global!
+ $wholeheader = ''; # $wholeheader is global!
+ $lang = @article;
+ for ($i = 0; $i <= $lang; $i+= 1) {
+ $wholeheader .= shift(@article);
+ };
+ # ... then get body
+ if (!(@article = $readserver->body($doit))) {
+ op(13,"\n$serverresponse Error: " . $readserver->code . ' ' . $readserver->message);
+ op(0,"Error reading body from $server.\n");
+ } else {
+ op(3,"$serverresponse".$readserver->code.' '.$readserver->message);
+ };
+ $wholebody = ''; # $wholebody is global!
+ $lang = @article;
+ for ($i = 0; $i <= $lang; $i+= 1) {
+ $wholebody .= shift(@article);
+ };
+};
+
+
+sub feed_article { #-# 1.2.01k
+# load article from disk
+ my $file = shift;
+ open(ARTICLE,"<$file") or op(15,"I/O ERROR while opening $file: $!\n");
+ $/='';
+ $wholeheader = <ARTICLE>; # $wholeheader is global!
+ @header = split(/\n/,$wholeheader); # @header is global!
+ undef $/;
+ $wholebody = <ARTICLE>; # $wholebody is global!
+ close(ARTICLE);
+ $/="\n";
+};
+
+
+sub check_article {
+# check article and generate followup
+ my($testgroup,$auto)=@_;
+ # $testgroup is 'none' for forced check, '' for feeding-mode
+ # $auto is '2' for forced check, '' for feeding-mode
+ # will use global $wholeheader, @header and $wholebody (from &get_article / &feed_article)
+ # will use global %config and %domain (from &readrcfile / &readdomains)
+ my(@body); # parts of the posting
+ my($newsreader,$nr); # specials
+ my($docheck,$sigokay); # trigger
+ my(@article,@duplicate,$frdompart,$frlocpart,$rplocpart,$rpdompart,$wrongsig);
+ # output
+ my($m,$f,$i,$flag,$sigstart,$query,$res,@mx,$key,$value,$testgroup_q,$postgroups);
+ # auxiliaries
+ my($tag,$monat,$jahr,$zeit,$wtag); # date
+ # will use global %header,%header_decoded,$debugmsg,%diag,$diaglevel
+ undef %header;
+ undef %header_decoded;
+ undef $debugmsg;
+ undef %diag;
+ undef $diaglevel;
+
+ local *ev = sub {
+ # evaluate variables
+ my ($i) = shift;
+ ($f = $config{$i}) =~ s/(\$[a-z{}'_-]+)/$1/gee;
+ $f;
+ };
+
+ # split $wholeheader into single headers
+ while ($_=shift @header) {
+ chomp;
+ if ($_ =~ /^\s+/) {
+ $_ =~ s/^\s*(.+)\s*$/$1/;
+ $header{lc($key)} .= "\n\t$_";
+ } elsif ($_ ne "\n") {
+ ($key,$value) = split /:/,$_,2;
+ if (exists $header{lc($key)}) {
+ push @duplicate,$key;
+ $diag{'duplicate'} = 1;
+ } else {
+ ($header{lc($key)} = $value) =~ s/^\s*(.+)\s*$/$1/;
+ };
+ };
+ };;
+
+ # return if not a test group
+ # or if posting is bot-reply or cmsg or keywords contain $trigger_ignore ...
+ if ($auto != 2) {
+ return if $header{'newsgroups'}!~/test/i;
+ return if $header{'message-id'} =~ /checkbot\.fqdn\.de>[ ]*$/i;
+ return if $header{'message-id'} =~ /checkbot-checked/i;
+ return if (defined($header{'control'}));
+ return if (defined($header{'keywords'}) and $header{'keywords'}=~/$trigger_ignore/io);
+ };
+
+ if ($feedmode) { #-# 1.2.01k
+ $auto = 3; # set $auto to unusual value
+ foreach $testgroup (@testgroups) {
+ $testgroup_q = quotemeta($testgroup); # quote meta characters ('.'!)
+ if ($header{'newsgroups'} =~ /$testgroup_q/) { # if one of the test groups is found in Newsgroups: ...
+ if ($postgroups != '') {
+ $postgroups .= ',';
+ };
+ $postgroups .= $testgroup; # ... add it to $postgroups and ...
+ if ($auto{$testgroup} <= $auto) {
+ $auto = $auto{$testgroup}; # ... reset $auto to the lowest value of all testgroups
+ };
+ };
+ };
+ return if $auto == 3; # return if $auto was not reset
+ $testgroup = $postgroups; # set $testgroup for posting a followup
+ };
+
+ $debugmsg .= " --- Posting Check Results ---\n";
+ # ... or if killfile is triggered (if check is not forced) ...
+ if ($auto != 2) {
+ $debugmsg .= " Checking posting; it's in a test group and neither bot-reply nor cmsg.\n";
+ # check if killfile is triggered and set $flag
+ foreach (@kill) {
+ ($key,$value) = @{$_};
+ if (defined($header{$key}) and $header{$key}=~/$value/i) {
+ $flag = 1 ;
+ $debugmsg .= " Killfile rule '$key=$value' triggered.\n";
+ };
+ }
+ };
+
+ # ... or if neither $trigger_check in Subject: nor auto-mode activated
+ $debugmsg .= " Subject: " . $header{'subject'} . "\n";
+ if ($header{'subject'} ne &hdecode($header{'subject'})) {
+ $debugmsg .= " Subject (decoded): " . &hdecode($header{'subject'}) . "\n";
+ };
+ if (&hdecode($header{'subject'}) =~ /$trigger_check/io or ($auto==2)) {
+ $docheck = 1;
+ if ($auto==2) {
+ $debugmsg .= " TRIGGER: Check forced via '-c'.\n";
+ $testgroup = $header{'newsgroups'};
+ } else {
+ $debugmsg .= " TRIGGER: Found \"$trigger_check\" in the \"Subject:\"-line, continuing check.\n";
+ };
+ }
+ else {
+ $debugmsg .= " TRIGGER: \"$trigger_check\" not found in \"Subject:\"-line";
+ if (!$auto or (&hdecode($header{'subject'}) =~ /$trigger_ignore/io) or $flag) {
+ $debugmsg .= ", terminating check.\n";
+ $debugmsg .= " --- End of Check Results ---\n\n";
+ op(15,"$header{'message-id'}:\n$debugmsg\n");
+ return;
+ } else {
+ $debugmsg .= "; auto-mode activated - no ignore, continuing check.\n";
+ };
+ };
+
+ # put decoded (q/p and base64) headers in %header_decoded
+ foreach $key (keys %header) {
+ $header_decoded{$key} = &hdecode($header{$key});
+ };
+
+ # generate debugmsg for duplicate headers
+ foreach (@duplicate) {
+ $debugmsg .= " $debugdiagmarker Duplicate header line: $_\n"
+ }
+
+ # try to detect the newsreader
+ if (defined($header{'user-agent'})) {
+ $newsreader=$header_decoded{'user-agent'}
+ } elsif(defined($header{'x-newsreader'})) {
+ $newsreader=$header_decoded{'x-newsreader'}
+ } elsif (defined($header{'x-mailer'})) {
+ $newsreader=$header_decoded{'x-mailer'}
+ }
+ if ((defined($newsreader)) and ($newsreader ne '')) {
+ KNOWN: {
+ $nr= 'oe', last KNOWN if $newsreader=~/Outlook Express/i;
+ $nr= 'moz', last KNOWN if ($newsreader=~/Mozilla/i and $newsreader!~/StarOffice/i);
+ $nr= 'agent', last KNOWN if ($newsreader=~/Forte.*Agent/i or $header{'message-id'}=~/^[a-zA-Z0-9=+]{28,34}\@/ or $header{'message-id'}=~/^$lt_alpha_num{8}\.\d{7,9}\@/ or $header{'message-id'}=~/^$lt_alpha_num{7}\.\d{2,3}\.\d\@/);
+ $nr= 'xnews', last KNOWN if ($newsreader=~/Xnews/ or $header{'message-id'}=~/^$lt_alpha_num{6}\.$lt_alpha_num{2}\.\d\@/); #-# 1.2.01l
+ $nr= 'gnus', last KNOWN if ($newsreader=~/Gnus/i or $header{'message-id'}=~/^$lt_alpha_num{10,11}\.fsf\@/o);
+ $nr= 'slrn', last KNOWN if ($newsreader=~/slrn/i or $header{'message-id'}=~/^slrn$lt_alpha_num{6}\.$lt_alpha_num{2,3}\.\w+\@/);
+ $nr= 'macsoup', last KNOWN if ($newsreader=~/MacSOUP/i or $header{'message-id'}=~/^$lt_alpha_num{7}\.$lt_alpha_num{13,14}[A-Z]\%[a-zA-Z\.]+\@/);
+ $nr= 'mpg', last KNOWN if ($newsreader=~/Gravity/i or $header{'message-id'}=~/^MPG\.$lt_hex_nibb{22}\@/o);
+ $nr= 'pine', last KNOWN if ($newsreader=~/Gravity/i or $header{'message-id'}=~/^Pine\.$gt_alpha_num{3}\.\d\.\d{2}\.\d{14}\.\d{4,5}-\d{6}\@/o);
+ $nr= 'xp', last KNOWN if ($newsreader=~/Gravity/i or $header{'message-id'}=~/^[a-zA-Z0-9\$\-]{11}\@/o);
+ $nr= 'pminews', last KNOWN if ($newsreader=~/Gravity/i or $header{'message-id'}=~/^[a-z]{16,21}\.$alpha_num{7}\.pminews\@/o);
+ }
+ }
+ if (!defined($nr)) {
+ $nr = '-';
+ $debugmsg .= " Could not identify newsreader.\n"
+ } else {
+ $debugmsg .= " Newsreader identified: $newsreader [$nr].\n"
+ };
+
+ # * ---> check for 8bit in headers
+ if($wholeheader=~/[\x80-\xFF]/) {
+ $diag{'8bitheader'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker 8bit-chars in header.\n";
+ };
+
+ # * ---> check from-header
+ ($frlocpart,$frdompart) = checkfromrp('From');
+
+ # * ---> check reply-to
+ if (defined($header{'reply-to'})) {
+ ($rplocpart,$rpdompart) = checkfromrp('Reply-To');
+ };
+
+ # * ---> check from == replyto
+ if(defined($header{'reply-to'}) && ((getmailaddress($header_decoded{'from'}))[0] eq (getmailaddress($header_decoded{'reply-to'}))[0])) {
+ $diag{'replytofrom'}=1 ;
+ $diaglevel ||= 1;
+ $debugmsg .= " $debugdiagmarker \"From:\" = \"Reply-To:\".\n";
+ };
+
+ # * ---> check message-id
+ ($dompart = $header{'message-id'}) =~ s/.*\@(.*)>$/$1/; # fqdn isolieren
+ $dompart = lc($dompart);
+ ($tld = $dompart) =~ s/.*\.([^.]+)$/$1/; # TLD isolieren
+ # no FQDN, but less than one word or numbers
+ if($dompart!~/(\D\w*\.)+(\D\w*$)/) {
+ $diag{'nomid'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker MID wrong: FQDN is just one word or just numbers.\n";
+ };
+ # invalid chars in domain
+ if($dompart =~ /[^a-z0-9\-.]/) {
+ $diag{'nomid'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker MID wrong: FQDN contains invalid characters.\n";
+ };
+ # check for valid TLD
+ if(!defined($domain{$tld})) {
+ $diag{'nomid'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker MID wrong: no valid TLD.\n";
+ };
+ # check for <unique%mailaddress@do.main> (USEFOR, used e.g. by MacSOUP)
+ ($f,undef,undef,$i,undef) = &getmailaddress($header_decoded{'from'});
+ $f = quotemeta($f);
+ if ($header{'message-id'} =~ /%$f>$/) {
+ $debugmsg .= " MID is <unique%address\@do.main>, see draft-ietf-usefor-msg-id-alt-00,\n";
+ $debugmsg .= " chapter 2.1.2 - not yet a good idea (but we do not mind ;-)).\n";
+ } elsif (($dompart eq $i) and ($nr eq 'moz') and ($header{'message-id'} =~ /^<$gt_hex_nibb{8}\.$gt_hex_nibb{4,8}\@/)) {
+ # Mozilla generates the MID from the FQDN of the mailaddress
+ $diag{'nomid'}=1;
+ $diaglevel ||= 1;
+ $debugmsg .= " $debugdiagmarker MID wrong: Mozilla takes FQDN of mailaddress.\n";
+ } elsif($dompart=~/^gmx\.(de|net|at|ch|li)$/) {
+ # special: GMX does not offer usenet service
+ $diag{'nomid'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker MID wrong: GMX does not offer usenet service.\n";
+ };
+ if (defined($diag{'nomid'})) {
+ $debugmsg .= " MID was \"$header{'message-id'}\".\n";
+ };
+
+ # * ---> check date
+ ($wtag,$tag,$monat,$jahr,$zeit) = (split / +/, $header{'date'});
+ if (!($wtag=~/\w{3},/)) {
+ $zeit = $jahr;
+ $jahr = $monat;
+ $monat = $tag;
+ $tag = $wtag;
+ };
+ if ($jahr < 1970) {
+ $diag{'date'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker \"Date:\" is incorrect: year < 1970.\n";
+ $debugmsg .= " \"Date:\" was: \"$header{'date'}\".\n";
+ };
+
+ # * ---> check for html
+ if(defined($header{'content-type'})&&$header{'content-type'}=~/html/i) {
+ $diag{'html'}=1;
+ $diaglevel=1;
+ $debugmsg .= " $debugdiagmarker HTML detected (no multipart/alternative!).\n";
+ };
+
+ # * ---> check for multiparts
+ if(defined($header{'content-type'}) and ($header{'content-type'}=~/multipart/)) {
+ $diag{'multipart'}=1;
+ $diaglevel ||= 1;
+ $debugmsg .= " $debugdiagmarker MIME-multipart identified.\n";
+ $debugmsg .= " Cannot check body of that posting - do not understand multipart yet.\n";
+ };
+
+ # apply checks to body only if there _is_ a body
+ if (defined($wholebody)) {
+ if(defined($header{'content-transfer-encoding'})) {
+
+ # * ---> check for q/p (body)
+ if ($header{'content-transfer-encoding'}=~/quoted/i){
+ # $diag{'qp'}=1; #-# 1.2.01k
+ # $diaglevel ||= 1; #-# 1.2.01k
+ # $debugmsg .= " $debugdiagmarker Content-transfer-encoding: quoted/printable.\n"; #-# 1.2.01k
+ $debugmsg .= " Content-transfer-encoding: quoted/printable.\n";
+ $debugmsg .= " Will decode that body now.\n";
+ # convert quoted-printables to 8bit
+ # $wholebody=~s/[ \t]\n/\n/sg; # RFC 1521 5.1 Rule #3
+ $wholebody=~s/=\n//sg; # RFC 1521 5.1 Rule #5
+ $wholebody=~s/=([0-9a-fA-F]{2})/pack("H2",$1)/sge;
+ };
+
+ # * ---> check for base64 (body)
+ if($header{'content-transfer-encoding'}=~/base64/i){
+ $diag{'base64'}=1;
+ $diaglevel=1;
+ $debugmsg .= " $debugdiagmarker Content-transfer-encoding: Base64.\n";
+ $debugmsg .= " Will decode that body now.\n";
+ $wholebody = decode_base64($wholebody); # do Base64-decoding
+ };
+ }
+
+ # split $wholebody into single lines
+ @body=split("\n",$wholebody);
+
+ # terminate and return if $trigger_ignore is found in first line
+ # (and $trigger_check not in Subject:) --> $docheck
+ if (!$docheck and ($body[0] =~ /$trigger_ignore/io)) {
+ $debugmsg .= " TRIGGER: \"$trigger_ignore\" found in \"Subject:\"-line or first line of posting; terminating check.\n";
+ $debugmsg .= " --- End of Check Results ---\n\n";
+ op(15,"$header{'message-id'}:\n$debugmsg\n");
+ return;
+ }
+
+ # * ---> check for charset / transfer-encoding
+ if(!defined($diag{'multipart'})) {
+ if($wholebody=~/[\x80-\xff]/){
+# (@problem) = $wholebody=~/([\x80-\xff])/g;
+ $debugmsg .= " Found 8bit-characters in body.\n";
+# $debugmsg .= " @problem\n";
+ if(defined($header{'content-type'})){
+ if($header{'content-type'}!~/charset=/i){
+ $diag{'nocharset'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker Header \"Content-Type:\" does not define charset.\n";
+ };
+ if($header{'content-type'}=~/us-ascii/) {
+ $diag{'nocharset'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker Charset is \"US-ASCII\".\n";
+ };
+ }else{
+ $diag{'nocharset'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker No charset defined.\n";
+ }
+ if(!defined($header{'content-transfer-encoding'})) {
+ $diag{'nocontenttransferenc'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker No content-transfer-encoding defined.\n";
+ };
+ }
+ }
+
+ # * ---> check for vcards
+ if($wholebody=~/(^begin:vcard\s*$)(.|[\n])+(^end:vcard\s*$)/im) {
+ $diag{'vcard'}=1;
+ $diaglevel ||= 1;
+ $debugmsg .= " $debugdiagmarker V-Card identified.\n";
+ };
+
+ $sigstart = $#body;
+ # sig-delimiter and (too) long sigs
+ for($i=$#body;$i>-1;$i--){ #-# 1.2.01i: fixed sigdelimiter first line
+ if (defined($diag{'base64'})) {
+ $body[$i] =~ s/\r$//; # remove carriage returns (CR-CR-LF to CR-LF)
+ };
+ if($body[$i]=~/^(- )?--[^-]?\s*$/){
+ $sigstart = $i;
+ $debugmsg .= " Possible sig-delimiter found in line " . ($i+1) . " of posting.\n";
+ if ($body[$i] !~/^(- )?-- $/ and $sigokay == 0) {
+ $diag{'sigdelimiter'} = 1;
+ $wrongsig = $body[$i];
+ $debugmsg .= " $debugdiagmarker Sig-delimiter in line " . ($i+1) . " is wrong.\n";
+ $debugmsg .= " Sig-delimiter was \"$wrongsig\".\n";
+ } else {
+ $sigokay ||= $i+1;
+ $debugmsg .= " Sig-delimiter is correct or not checked.";
+ if ($diag{'sigdelimiter'} == 1) {
+ delete $diag{'sigdelimiter'};
+ $debugmsg .= " - Reset error-message.\n";
+ } else {
+ $debugmsg .= "\n"; };
+ };
+ if($sigokay > 0) {
+ $f = $sigokay-1;
+ } else {
+ $f = $i;
+ };
+ if ($f+4<$#body) {
+ $diag{'longsig'}=1;
+ $diaglevel ||= 1;
+ $debugmsg .= " $debugdiagmarker Sig is too long [starting line ".($f+2)." - ending line ".($#body+1)."].\n";
+ };
+ }
+ }
+ if ($diag{'sigdelimiter'} == 1) {$diaglevel ||= 1;};
+
+ # lines to long
+ LINECHECK:
+ for ($i=$sigstart; $i>=0; $i--) {
+ last LINECHECK if(!defined($body[$i]));
+ if(($body[$i]=~/^.{75,}$/) and ($body[$i]!~/^[ ]*[>|:]/)) {
+ $diag{'longlines'}=1;
+ $diaglevel ||= 1;
+ $debugmsg .= " $debugdiagmarker Line " . ($i+1) . " too long and not quoted.\n";
+ $debugmsg .= " Offending line: " . $body[$i] . "\n";
+ };
+ }
+
+ if ($sigstart < $#body) {
+ SIGCHECK:
+ for ($i=$sigstart; $i<=$#body; $i++) {
+ last SIGCHECK if(!defined($body[$i]));
+ if($body[$i]=~/^.{81,}$/) {
+ $diag{'longlinesig'}=1;
+ $diaglevel ||= 1;
+ $debugmsg .= " $debugdiagmarker Line " . ($i-$sigstart) . " of signature too long.\n";
+ $debugmsg .= " Offending line: " . $body[$i] . "\n";
+ }
+ }
+ }
+ } else {
+ $debugmsg .= " Message does not contain body.\n"
+ };
+
+ # if config for any problem is empty (.rc-file!), reset diag
+ foreach $i (keys %diag) {
+ if(!defined($config{$i}) and defined($diag{$i})) {
+ delete $diag{$i};
+ $debugmsg .= " ! Configuration: Text for [$i] missing - problem was found, but won't be reported.\n";
+ }
+ }
+
+ # increase diaglevel if pedantic is on
+ if ($pedantic) { $diaglevel += 1; };
+
+ $debugmsg .= " --- End of Check Results ---\n\n";
+
+ # if subject == 'check' or auto == 1 and $diaglevel > 1:
+ # post followup
+ if ($docheck or ($auto && ($diaglevel > 1))) {
+ op(2,"Got one! ---> $header{'message-id'}\n");
+ op(2,"Generating followup, writing to $testgroup ...");
+ # generate followup
+ @article = $config{'head'};
+ push @article, "Newsgroups: $testgroup\n";
+ ($m=$header{'message-id'})=~s/\@(.*)>$/%$1/;
+ push @article, 'Message-ID: '.$m.'@checkbot.fqdn.de>'."\n";
+ if(defined($header{'references'})) {
+ push @article, "References: $header{'references'} $header{'message-id'}\n"
+ } else {
+ push @article, "References: $header{'message-id'}\n"
+ }
+ ($wtag,$monat,$tag,$zeit,$jahr) = (split / +/, (scalar gmtime));
+ push @article, "Date: $wtag, $tag $monat $jahr $zeit GMT\n";
+ $f = "Subject: ";
+ $f .= "Re: " unless ($header_decoded{'subject'}=~/^[ \t]*re:/i);
+ $f .= &encode_header($header_decoded{'subject'});
+ push @article, "$f\n";
+ push @article, "X-Artchk-Version: artchk.pl (mod.) $version\n";
+ if($header_decoded{'subject'}=~/(^|\s)replybymail(\s|$)/) {
+ push @article, "X-Sorry: 'replybymail' not supported in this version.\n";
+ }
+ if ($auto==2) {
+ push @article, "X-Comment: Check enforced by operator using '$0 -c'.\n";
+ }
+ push @article, "MIME-Version: 1.0\n";
+ push @article, "Content-Type: text/plain; charset=ISO-8859-1\n";
+ push @article, "Content-Transfer-Encoding: 8bit\n";
+ push @article, "\n";
+ if ($auto==2) {
+ push @article, $config{'header-forced'}
+ } elsif ($docheck) {
+ push @article, $config{'header'}
+ } elsif ($auto) {
+ push @article, $config{'header-auto'}
+ } else {
+ push @article, "\nCHECKBOT INTERNAL ERROR!\n"
+ }
+ push @article, "\n";
+ push @article, "$header_decoded{'from'} schrieb:\n\n";
+ if(scalar @body==0){push @article, "[nichts]\n\n"}
+ else{for(0..4){push @article, '>'.$body[$_]."\n" if defined $body[$_]}}
+ push @article, "[...]\n" if (defined($body[5]));
+ push @article, "\n";
+
+ if(scalar keys %diag !=0){
+ push @article, $config{'intro'},"\n";
+ if (defined($diag{'duplicate'}) && $diag{'duplicate'}==1) {
+ push @article, $config{'duplicate'},"\n";
+ while ($_=shift @duplicate) {
+ push @article, "| $_\n";
+ };
+ push @article, "\n"; #-# 1.2.01k
+ };
+ foreach $i (qw/from from-domain from-roles noname reply-to reply-to-domain reply-to-roles replytofrom date
+ nomid 8bitheader nocharset nocontenttransferenc sigdelimiter longsig
+ multipart base64 html vcard longlines longlinesig /){ #-# 1.2.01k: removed qp
+ if (defined($diag{$i}) && $diag{$i}==1) {
+ push @article, ev($i), "\n"; # Variablen expandieren
+ };
+ if (defined($config{"$i-$nr"}) && $diag{$i}==1) {
+ push @article, ev("$i-$nr"), "\n"; # Variablen expandieren
+ };
+ };
+ if (defined($config{'umlauts'})) {
+ push @article, $config{'umlauts'},"\n" if((defined($diag{'nocharset'})) && ($diag{'nocharset'}==1) or
+ (defined($diag{'8bitheader'})) && ($diag{'8bitheader'}==1));
+ };
+ if (defined($config{'violation'}) && $diaglevel > 1) { #-# 1.2.01k
+ push @article, "$config{'violation'}\n";
+ };
+ push @article, $config{'nr'},"\n";
+ if (defined($nr) and (defined($config{$nr}))) {
+ push @article, ev('nr-known'), "\n"; # Variablen expandieren
+ push @article, ev($nr), "\n"; # Variablen expandieren
+ };
+ if (defined($header{'x-trace'}) and ($header{'x-trace'}=~/^fu-berlin.de/) and defined($config{'newscis'})) {
+ push @article, "$config{'newscis'}\n";
+ };
+ }else{
+ push @article, $config{'allok'},"\n";
+ }
+
+ if ($header_decoded{'subject'}=~ /$trigger_check verbose/io) {
+ push @article, $config{'debug'};
+ ($f=$debugmsg)=~s/\n/\n\| /g;
+ $f = '| ' . $f . "\n\n";
+ push @article, $f;
+ };
+
+ push @article, $config{'footer'};
+
+ if ($feedmode) { #-# 1.2.01k ---->
+ # open server for posting
+ if ($postingserver ne '') {
+ $postserver = &connectserver($postingserver,$postingport,$posts_user,$posts_pass)
+ } else {
+ $postserver = &connectserver($server,$port,$s_user,$s_pass);
+ };
+ $f = \$postserver;
+ } else { #-# 1.2.01k <-----
+ if ($postingserver ne '') {
+ $f = \$postserver;
+ $i = "$postingserver";
+ if ($postingport ne '') {
+ $i .= "(Port $postingport)";
+ }
+ } else {
+ $f = \$readserver;
+ $i="$server";
+ if ($port ne '') {
+ $i .= " (Port $port)";
+ }
+ }
+ };
+ if (!($$f->post(@article))) { #-# 1.2.01g
+ op(13,"\n$serverresponse Error: " . $$f->code . ' ' . $$f->message);
+ op(0,"Error writing followup to $i.\n");
+ if ($$f->message =~ /imeout/ and $postingserver ne '') {
+ op(10,"Retry due to timeout ...");
+ $postserver = &connectserver($postingserver,$postingport,$posts_user,$posts_pass);
+ if (!($postserver->post(@article))) {
+ op(13,"\n$serverresponse Error: " . $$f->code . ' ' . $$f->message);
+ op(0,"Error writing followup to $i during retry.\n");
+ } else {
+ op(2," done (written to $i).\n");
+ op(2,"Message-ID was $m\@checkbot.fqdn.de>.\n");
+ op(3,"$serverresponse".$postserver->code.' '.$postserver->message);
+ };
+ };
+ } else {
+ op(2," done (written to $i).\n");
+ op(2,"Message-ID was $m\@checkbot.fqdn.de>.\n");
+ op(3,"$serverresponse".$$f->code.' '.$$f->message);
+ };
+ if ($feedmode) { #-# 1.2.01k
+ $postserver->quit;
+ };
+ op(14,"\n$header{'message-id'}:\n$debugmsg\n\n");
+ } else {
+ op(15,"$header{'message-id'}:\n$debugmsg\n");
+ }
+}
+
+################################################################
+# Subroutines: get_mail_address
+# encode_header / hdecode / dodecode
+# evaluate variables
+# generic output routinte (instead of 'print')
+# connect to server
+
+sub getmailaddress {
+ my($raw)=shift;
+ my($tmp,$address,$name,$lp,$dp,$type);
+ if($raw=~/^<?($r_address)>?$/) {
+ $type = 1;
+ $address = $1;
+ $name = '';
+ } elsif($raw=~/^($r_address)\s+\($r_paren_phrase\)\s*$/) {
+ $type = 2;
+ $address = $1;
+ $tmp = quotemeta($address);
+ ($name = $raw) =~ s/^$tmp\s+\(([^()]+)\)$/$1/;
+ } elsif($raw=~/^(($r_quoted_word|$r_unquoted_word)(\s+($r_quoted_word|$r_unquoted_word))*)\s+<$r_address>\s*$/) {
+ $type = 3;
+ $name = $1;
+ ($address = $raw) =~ s/.*<($r_address)>\s*$/$1/;
+ };
+ ($lp = $address) =~ s/^([^@]+)@.*/$1/;
+ ($dp = $address) =~ s/\S*\@(\S*)$/$1/;
+ chomp ($address, $name, $lp, $dp, $type);
+ foreach $tmp ($address, $name, $lp, $dp, $type) {
+ $tmp = lc($tmp);
+ };
+ return $address, $name, $lp, $dp, $type;
+}
+
+sub checkfromrp {
+ # * ---> check from-header / reply-to
+ my ($headername) = shift;
+ my $hname = lc($headername);
+ my($address,$name,$locpart,$dompart,$type)=&getmailaddress($header_decoded{$hname});
+ my $tld;
+ ($tld = $dompart) =~ s/.*\.([^.]+)$/$1/; # isolate TLD
+ $tld = lc($tld);
+ if ($hname eq 'from') {
+ if($type==1) {
+ $debugmsg .= " \"From:\"-header is type 1 [address\@do.main].\n";
+ }elsif($type==2) {
+ $debugmsg .= " \"From:\"-header is type 2 [address\@do.main (full name)].\n";
+ }elsif($type==3) {
+ $debugmsg .= " \"From:\"-header is type 3 [full name <address\@do.main>].\n";
+ }else{
+ $diag{'from'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker \"From:\"-syntax is incorrect.\n";
+ };
+ } else {
+ if($type==0) {
+ $diag{'reply-to'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker \"Reply-To:\" is incorrect.\n";
+ };
+ }
+ $f = lc($dompart);
+ if($f =~ /[^a-z0-9\-.]/) {
+ $diag{$hname}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker \"$headername:\" is incorrect: invalid chars in domain.\n";
+ };
+ if($type!=0) {
+ # domain
+ if(!defined($domain{$tld})) {
+ $diag{"$hname".'-domain'}=1;
+ $diaglevel=2;
+ $debugmsg .= " $debugdiagmarker \"$headername:\" is incorrect: no valid TLD.\n";
+ # MX-/A-lookup
+ } else {
+ if ($online) {
+ $res = Net::DNS::Resolver -> new();
+ $res->usevc(1);
+ $res->tcp_timeout(15);
+ $i='okay'; #-# 1.2.01i: fixed 'bug' in logging DNS-checks
+ @mx = mx($res,$dompart) or $i = $res->errorstring;
+ $debugmsg .= " DNS (\"$headername:\"): $i.\n"; #-# 1.2.01i: fixed 'bug' in logging DNS-checks
+ if ($i eq 'NXDOMAIN' or $i eq 'NOERROR') {
+ $debugmsg .= " No MX-record for \"$dompart\": $i.\n";
+ $i='okay'; #-# 1.2.01i: fixed 'bug' in logging DNS-checks
+ $query = $res->search($dompart) or $i = $res->errorstring;
+ $debugmsg .= " DNS (\"$headername:\"): $i.\n"; #-# 1.2.01i: fixed 'bug' in logging DNS-checks
+ if ($i eq 'NXDOMAIN' or $i eq 'NOERROR') {
+ $debugmsg .= " $debugdiagmarker No A-record either: $i - \"$headername:\" is not replyable.\n";
+ $diag{"$hname".'-domain'}=1;
+ $diaglevel=2;
+ };
+ };
+ };
+ };
+ # no name, just address?
+ if ($hname eq 'from') {
+ if($name !~ /[a-z][^.]\S*\s+\S*([a-z][^.]\S*)+/i) {
+ $diag{'noname'}=1;
+ $diaglevel ||= 1;
+ $debugmsg .= " $debugdiagmarker \"From:\" does not contain full name.\"\n";
+ };
+ };
+ # check for role accounts
+ ROLES: foreach $f (@roles) {
+ if ($f eq lc($locpart)) {
+ $diag{"$hname".'-roles'}=1;
+ $diaglevel ||= 1;
+ $debugmsg .= " $debugdiagmarker \"$headername:\" contains role account.\"\n";
+ last ROLES;
+ };
+ };
+ };
+ if (defined($diag{$hname}) or defined($diag{"$hname".'-domain'}) or defined($diag{"$hname".'-roles'}) or ($debuglevel > 4)) {
+ $debugmsg .= " \"$headername:\": \"$header{$hname}\".\n";
+ if ($header{$hname} ne $header_decoded{$hname}) {
+ $debugmsg .= " \"$headername:\" (decoded): \"$header_decoded{$hname}\".\n";
+ };
+ } elsif (defined($diag{'noname'}) and ($hname eq 'from')) {
+ $debugmsg .= " \"From:\": \"$header{'from'}\".\n";
+ if ($header{'from'} ne $header_decoded{'from'}) {
+ $debugmsg .= " \"From:\" (decoded): \"$header_decoded{'from'}\".\n";
+ };
+ };
+ return ($locpart,$dompart);
+}
+
+sub encode_header {
+ my $header=shift;
+ my ($word,$space,$encoded_header);
+ while ($header=~/(\S+)(\s*)/g) {
+ ($word,$space) = ($1,$2);
+ if ($word=~/[\x80-\xFF]/) {
+ $word='=?iso-8859-1?Q?'.encode_qp($word).'?=';
+ }
+ $encoded_header .= "$word$space";
+ }
+ $encoded_header =~ s/\?=(\s+)=\?iso-8859-1\?Q\?/$1/g;
+ return $encoded_header;
+}
+
+
+sub hdecode {
+ my $header=shift;
+ if ($header=~/=\?.*\?(.)\?(.*)\?=/) {
+ $header=~s/=\?.*\?(.)\?(.*)\?=/&dodecode($1,$2)/ge;
+ };
+ $header=~s/\n\t//; # unfold headers
+ return $header;
+}
+
+
+sub dodecode {
+ # decode RFC 1522 headers
+ my $enc=shift;
+ my $etext=shift;
+
+ if($enc=~/^q$/i){
+ $etext=decode_qp($etext);
+ $etext=~s/_/' '/ge;
+ }elsif($enc=~/^b$/i){
+ $etext=decode_base64($etext);
+ }else{$etext=''}
+ return $etext;
+}
+
+
+sub op {
+# (debug) output
+# level 0 : error messages, introduction/end
+# level 1 (-v) : + configuration and summaries
+# level 2 (-vv) : + progress indicator
+# level 3 (-vvv) : + NNTP-replies from server(s)
+# level 4 (-vvvv) : + debug-output from check-routines
+# level >=10 : output also to logfile if activated
+ my($level,$text,$handle) = @_;
+ if ($level >= 10) {
+ if ($logging) { print LOG $text; };
+ $level -= 10;
+ };
+ $handle ||= 'STDOUT';
+ if ($debuglevel >= $level and not $feedmode) {
+ print $handle $text;
+ };
+}
+
+
+
+sub connectserver {
+ my($server,$port,$s_user,$s_pass) = @_;
+
+ # connect to server
+ op(0,"Connecting to news server ...");
+ my $c = new News::NNTPClient($server,$port);
+
+ if (!($c->code)) {
+ op(0,"\nCan't connect to server. Aborting.\n");
+ die "\nCan't connect to server. Aborting.\n";
+ } else {
+ op(0," done.\n");
+ }
+
+ $c->postok() or op(0,"Server does not allow posting?!\n");
+
+ op(3,"$serverresponse".$c->code.' '.$c->message);
+
+ # switch off error messages from News::NNTPClient
+ $c->debug(0);
+
+ # mode reader
+ op(1,'MODE reader ...');
+ if (!($c->mode_reader)) {
+ op(10,"\n$serverresponse Error: " . $c->code . ' ' . $c->message . "Aborting.\n");
+ die '$serverresponse Error: ' . $c->code . ' ' . $c->message . "Aborting.\n";
+ } else {
+ op(1," done.\n");
+ op(3,"$serverresponse".$c->code.' '.$c->message);
+ };
+
+ # authorize, if needed
+ if ($s_user ne '') {
+ op(1,"Authentification ...");
+ if ($c->authinfo($s_user,$s_pass)) {
+ op(1," done.\n");
+ } else {
+ op(0,"\nAuthentification failure. Aborting.\n");
+ die "\nAuthentification failure. Aborting.\n";
+ }
+ op(3,"$serverresponse", $c->code, ' ', $c->message);
+ };
+
+ op(0,"\n");
+ $c;
+}
+
+
+################################################################
+# Subroutines for reading / writing files
+# - read rc
+# - read/write ini
+# - read domains
+
+sub readrcfile {
+ my($a,$i);
+ open(RC,'<'.$pathtoini.$rcname.'.rc')||die "Could not open $pathtoini"."$rcname.rc for reading: $!";
+ $a='';
+ until(eof(RC)){
+ $i=<RC>;
+ next if(substr($i,0,1) eq ';');
+ if($i=~/^\[.*\]$/){ $a=substr($i,1,-2);next; }
+ $config{$a}.=$i;
+ }
+ close(RC);
+ # check for _necessary_ entries
+ foreach $i (qw/head header header-auto footer intro allok nr debug/) {
+ if(!defined($config{$i})){
+ op(0,"The entry [$i] is missing in the $rcname.rc file. This entry\n");
+ op(0,"is necessary.\n");
+ exit(1);
+ }
+ }
+ # check for other entries
+ foreach $i (qw/multipart html vcard nocharset nocontenttransferenc base64 nomid
+ nomid-moz longlines longlinesig 8bitheader replytofrom reply-to sigdelimiter
+ sigdelimiter-oe date from noname longsig umlauts nr-known oe moz agent
+ xnews gnus macsoup slrn newscis from-domain from-roles reply-to-domain reply-to-roles/) { #-# 1.2.01k: removed qp
+ if(!defined($config{$i})){
+ op(0,"\n.rc: The entry [$i] is missing in the $rcname.rc file.\n");
+ op(0," Corresponding check will be skipped.\n");
+ }
+ }
+}
+
+
+sub readini {
+ my($a,$b,$c);
+ open(INI,'<'.$pathtoini.$ininame.'.ini')||die "Could not open $pathtoini"."$ininame.ini for reading: $!";
+ until(eof(INI)) {
+ $c=<INI>;
+ if ($c=~/=/) { # if '=' is found in line
+ chomp(($a,$b)=split(/=/,$c)); # split it into parametername and -contents
+ $a=~s/^\s*(.*?)\s*$/$1/g; # delete leading/trailing whitespace
+ $b=~s/^\s*(.*?)\s*$/$1/g; # delete leading/trailing whitespace
+ if ($a eq 'reader') {
+ chomp(($server,$port)=split(/,/,$b));
+ } elsif ($a eq 'reader_user') {
+ chomp($s_user=$b);
+ } elsif ($a eq 'reader_pass') {
+ chomp($s_pass=$b);
+ } elsif ($a eq 'poster') {
+ chomp(($postingserver,$postingport)=split(/,/,$b));
+ } elsif ($a eq 'poster_user') {
+ chomp($posts_user=$b);
+ } elsif ($a eq 'poster_pass') {
+ chomp($posts_pass=$b);
+ } elsif ($a eq 'trigger_check') {
+ chomp($trigger_check=$b);
+ } elsif ($a eq 'trigger_ignore') {
+ chomp($trigger_ignore=$b);
+ } elsif ($a eq 'rcfile') {
+ chomp($rcname=$b);
+ } elsif ($a eq 'killfile') {
+ chomp($killname=$b);
+ }
+ } elsif ($c =~/checkgroups:/) {
+ until(eof(INI)){
+ chomp(($a,$b,$c)=split(/ /,<INI>));
+ @testgroups = (@testgroups, $a) unless ($a!~/^\w+(\.\w+)+/);
+ if ($b eq 'y') {
+ $auto{$a} = 1;
+ }else{
+ $auto{$a} = 0;
+ };
+ $watermark{$a} = $c;
+ if (!defined($watermark{$a})) {$watermark{$a} = 0};
+ }
+ }
+ }
+ close(INI);
+ if($server eq '') {
+ op(0,"You have to define a reading server in $ininame.ini\n");
+ exit(1);
+ }
+ if($trigger_check eq '') {
+ $trigger_check='check';
+ }
+ if($trigger_ignore eq '') {
+ $trigger_ignore='(ignore)|(no[ ]*repl(y|(ies)))|(nocheck)';
+ }
+ if($rcname eq '') {
+ $rcname=$ininame;
+ } elsif ($rcname=~/\.rc$/) {
+ $rcname=~s/(.*?)\.rc$/$1/;
+ }
+ if($killname eq '') {
+ $killname=$ininame;
+ } elsif ($killname=~/\.kill$/) {
+ $killname=~s/(.*?)\.kill$/$1/;
+ }
+ if(scalar(@testgroups) == 0) {
+ op(0,"You have to define at least one testgroup in $ininame.ini\n");
+ exit(1);
+ }
+}
+
+
+sub writeini {
+ my($r,$tmp,$point);
+ open(INI,'<'.$pathtoini.$ininame.'.ini')||die "Could not open $pathtoini"."$ininame.ini for reading: $!";
+ until(eof(INI)) {
+ $r = <INI>;
+ $tmp .= $r;
+ if ($r =~/checkgroups:/) {
+ last;
+ }
+ }
+ close (INI);
+ open(INI,'>'.$pathtoini.$ininame.'.ini')||die "Could not open $pathtoini"."$ininame.ini for writing: $!";
+ print INI $tmp;
+ foreach $testgroup (@testgroups) {
+ print INI "$testgroup ";
+ if ($auto{$testgroup} == 0) {
+ print INI 'n '
+ }else{
+ print INI 'y '
+ };
+ print INI "$watermark{$testgroup}\n";
+ }
+ close(INI);
+}
+
+
+sub readdomains {
+ my ($i,@domains);
+ open(DOM,'<'.$pathtoini.'domains')||die "Could not open \"$pathtoini"."domains\" for reading: $!";
+ chomp(@domains = split(/ /,<DOM>));
+ close(DOM);
+ $i = 0;
+ until(!defined(@domains[$i])) {
+ $domain{$domains[$i]} = 'valid';
+ $i++;
+ };
+}
+
+__END__