3 # Automatic Article Checker
4 # v1.6 Copyright (C) June 2, 1999 by Heinrich Schramm
5 # mailto:heinrich@schramm.com
7 # converted to perl by Wilfried Klaebe <wk@orion.toppoint.de>
8 # (not really converted, more or less rewritten in perl)
11 # by Thomas Hochstein <THochstein@gmx.de> since March/April 2000
12 # (c) artchk.pl (mod.) January 06, 2001 by Thomas Hochstein
14 # _________ ATTENTION please! - This is still a BETA version! _________
16 # ------------------------------------------------------------------------------
17 # This program is free software; you can redistribute it and/or modify it under
18 # the terms of the GNU General Public License as published by the Free
19 # Software Foundation; either version 2 of the License, or (at your option)
21 # This program is distributed in the hope that it will be useful, but WITHOUT
22 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
23 # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
25 # ------------------------------------------------------------------------------
27 # You will need the following modules from CPAN:
33 # ------------------------------------------------------------------------------
35 # You will have to create an artchk.pl.ini / artchk.pl.rc file.
36 # Please see readme.txt for details.
38 # Please use this program with care and sense of responsibility!
41 ##################################################################
43 ###-### mark for temp. changes
44 #-# 1.2.01g changes new in that version
45 #-# {RKELLER} Contributed by Reiner Keller <keller@dlrg.de>
48 use MIME::QuotedPrint;
51 use File::Basename; #-# {RKELLER}
54 $version = 'V 1.2.01k BETA'; # Stand: 2001-10-13
55 $online = 0; # permanent connection to the net
56 $serverresponse = "# NNTP:"; # intro for debugmsg (NNTP status response)
57 $debugdiagmarker = "* ->"; # intro for debugmsg (diag{...} set)
58 @roles = qw/abuse noc security
59 root sysop admin newsmaster
60 postmaster hostmaster usenet news webmaster www uucp ftp/;
61 $hex_nibb = '[0-9a-fA-F]';
62 $gt_hex_nibb = '[0-9A-F]';
63 $lt_hex_nibb = '[0-9a-f]';
64 $alpha_num = '[0-9a-zA-Z]';
65 $lt_alpha_num = '[0-9a-z]';
66 $gt_alpha_num = '[0-9A-Z]';
67 # definitions from s-o-1036
68 $r_unquoted_char_a = '[#$%&\'|*+{}~\-/0123456789=?A-Z^_`a-z]'; # correct definition (for mailaddress)
69 $r_unquoted_word_a = "$r_unquoted_char_a+"; # correct definition (for mailaddress)
70 $r_unquoted_char = '[#$%&\'|*+{}~\-/0123456789=?A-Z^_`a-z\x80-\xFF]'; # definition including \x80-\xFF (8bit)
71 $r_unquoted_word = "$r_unquoted_char+"; # definition including \x80-\xFF (8bit)
72 $r_quoted_char = '[!@,;:.\[\]#$%&\'|*+{}~\-/0123456789=?A-Z^_`a-z\x80-\xFF]'; # definition including \x80-\xFF (8bit)
73 $r_quoted_word = "\"($r_quoted_char|\\s)+\""; # definition including \x80-\xFF (8bit)
74 $r_paren_char = '["!@,;:.\[\]#$%&\'|*+{}~\-/0123456789=?A-Z^_`a-z\x80-\xFF]'; # definition including \x80-\xFF (8bit)
75 $r_paren_phrase = "($r_paren_char|\\s)+"; # definition including \x80-\xFF (8bit)
76 $r_plain_word = "$r_unquoted_word|$r_unquoted_word"; # definition including \x80-\xFF (8bit)
77 $r_plain_phrase = "$r_plain_word(\\s+$r_plain_word)*"; # definition including \x80-\xFF (8bit)
78 $r_address = "$r_unquoted_word_a(\\.$r_unquoted_word_a)*\@$r_unquoted_word_a(\\.$r_unquoted_word_a)*";
81 # get commandline parameters
84 if ($f =~ /^-d(.*)/) {
86 } elsif ($f =~ /-(v+)/) {
87 $debuglevel = length($1);
88 } elsif ($f =~ /-p(.*)/) {
90 } elsif ($f =~ /-n(.*)/) {
92 if ($ininame=~/\.ini$/) {
93 $ininame=~s/(.*?)\.ini$/$1/;
95 } elsif ($f =~ /-c(.*)/) {
97 } elsif ($f =~ /^-l(.*)/) {
99 if ($logfile =~/\.log$/) {
100 $logfile=~s/(.*?)\.log$/$1/;
102 } elsif ($f =~ /--log/) {
104 } elsif ($f =~ /--feedmode/) { #-# 1.2.01k
105 $feedmode = 1; #-# 1.2.01k
106 } elsif ($f =~ /--pedantic/) { #-# 1.2.01k
107 $pedantic = 1; #-# 1.2.01k
111 # set parameters to default, if necessary / exit, if disabled
112 if (!defined($debuglevel)) {$debuglevel = 0};
113 if (!defined($ininame)) {$ininame = basename ($0)}; #-# {RKELLER}
114 exit (10) if (-e "$0.disabled"); # exit if "artchk.pl.disabled" exists
115 exit (10) if (-e "$ininame.disabled"); # exit if ".disabled" exists
116 if (!defined($pathtoini)) {
117 $pathtoini = dirname ($0).'/' #-# {RKELLER}
118 } elsif ($pathtoini !~ /.*(\/|\\)$/) {
121 if (!defined($checkpost) or ($checkpost!~/<\S+\@\S+>/)) {$checkpost = 'no'};
122 if (!defined($logfile)) {$logfile = "$ininame"};
126 open LOG, ">>$pathtoini$logfile.log" || die "Could not open $pathtoini$logfile.log for appending: $!";
127 if ($feedmode) { #-# 1.2.01k
128 select((select(LOG), $| = 1)[0]); # set autoflush
133 op(10,"\n-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-\n\n");
134 op(10,"This is artchk.pl (mod.) $version started on ".scalar(gmtime)." GMT.\n");
135 op(0,"Send suggestions & comments to <artchk\@akallabeth.de>.\n\n");
137 # read .rc-file / .ini-file / domains / killfile
141 if (-e "$killname.kill") {
142 open KILL, "<$pathtoini$killname.kill" || die "Could not open $pathtoini$killname.kill for reading: $!";
145 s/#.+//; # drop comments
146 s/^\s+//; # drop whitespace before
147 s/\s+$//; # drop whitespace after
149 my ($key,$value) = split(/\s*=\s*/,$_,2); # header = regexp
150 push @{ $kill[scalar(@kill)] },lc($key),lc($value);
155 # print configuration
156 op(1,"\nDebug-Level : $debuglevel\n");
157 op(1, "Path to files : $pathtoini\n");
158 op(1, "Filenames : $ininame.ini / $rcname.rc / $logfile.log\n");
159 op(1, "Trigger 'check' : $trigger_check\n");
160 op(1, "Trigger 'ignore' : $trigger_ignore\n");
161 op(1, "Newsserver (read): $server $port\n");
162 op(1, "Newsserver (post): $postingserver $postingport\n");
163 if ($checkpost eq 'no') {
164 op(1, 'Groups to check :');
165 foreach $testgroup (@testgroups) {op(1, " $testgroup")};
167 op(11, "Posting to check: $checkpost\n");
170 op(1, "---------- Starting connection procedure ----------\n");
172 if ($feedmode) { #-# 1.2.01k ---->
175 $file=~s/(\S*).*/$1/;
176 &feed_article($file); # will set $wholeheader, @header and $wholebody (global!)
179 } else { #-# 1.2.01k <-----
180 # open server (for reading)
181 $readserver = &connectserver($server,$port,$s_user,$s_pass);
183 # open server (for posting), if specified
184 if ($postingserver ne '') { $postserver = &connectserver($postingserver,$postingport,$posts_user,$posts_pass) };
186 # main loop - check all postings in all groups
187 op(1,"---------- Starting checks ----------");
189 if ($checkpost eq 'no') {
190 foreach $testgroup (@testgroups) {
191 op(1,"\n---------- New group ----------");
192 op(1,"\nOpening group $testgroup ...");
193 # get low-/high-marks of $testgroup
194 if (!(($low, $high) = ($readserver->group($testgroup)))) {
195 op(13,"\n$serverresponse Error: " . $readserver->code . ' ' . $readserver->message . "Skipping group.\n");
196 op(0,"Error opening group $testgroup on $server.\n");
199 op(3,"$serverresponse".$readserver->code.' '.$readserver->message);
200 op(11,"\n$testgroup: $low ---> $high; first to be checked: $watermark{$testgroup}\n");
201 if ($watermark{$testgroup} > ($high + 2)) {
202 op(1,"! High watermark of group $testgroup is to low - resetting counter ...");
203 $watermark{$testgroup} = $high;
205 if ($watermark{$testgroup} > $low) {$low = $watermark{$testgroup}};
206 if ($watermark{$testgroup} > $high) {
207 op(1,"Nothing new to check in $testgroup ... terminating.\n");
209 op(1,'Starting checks, ');
210 if($auto{$testgroup}) {
211 op(1,"generating followups for any problem detected (auto-mode).\n");
213 op(1, "only generating followups if requested.\n");
218 for ($doit = $low; $doit <= $high; $doit += 1) {
220 op(2,"Now getting: __> $doit <__ --- $togo to go ...\n");
221 &get_article($doit); # will set $wholeheader, @header and $wholebody (global!)
222 &check_article($testgroup,$auto{$testgroup});
225 # remmber last tested posting
226 $watermark{$testgroup} = $high + 1;
229 op(1,"Rewriting .ini-file ... ");
235 op(1,"\nNow getting: $checkpost\n");
236 &get_article($checkpost); # will set $wholeheader and $wholebody (global!)
237 &check_article('none',2);
240 op(1,"\n\n---------- Termination sequence ... ----------");
241 op(1,"\nartchk.pl (mod.) $version signing off.\n");
242 # close server and files
244 if ($postingserver ne '') { $postserver->quit };
248 op(15,"$0 $version terminated successfully on ".scalar(gmtime)." GMT.\n");
251 op(0,"Program terminated on ".scalar(gmtime)." GMT.\n\n");
252 op(0,"Thank you for using.\n");
255 ################################################################
256 # Main subroutines: get article / feed article / check article
259 # load article via NNTP
263 # parse posting: first get headers ...
264 if (!(@article = $readserver->head($doit))) {
265 op(13,"\n$serverresponse Error: " . $readserver->code . ' ' . $readserver->message);
266 op(0,"Error reading header from $server.\n");
268 op(3,"$serverresponse".$readserver->code.' '.$readserver->message);
270 # split @article and add all lines to $wholeheader
271 @header = @article; # @header is global!
272 $wholeheader = ''; # $wholeheader is global!
274 for ($i = 0; $i <= $lang; $i+= 1) {
275 $wholeheader .= shift(@article);
278 if (!(@article = $readserver->body($doit))) {
279 op(13,"\n$serverresponse Error: " . $readserver->code . ' ' . $readserver->message);
280 op(0,"Error reading body from $server.\n");
282 op(3,"$serverresponse".$readserver->code.' '.$readserver->message);
284 $wholebody = ''; # $wholebody is global!
286 for ($i = 0; $i <= $lang; $i+= 1) {
287 $wholebody .= shift(@article);
292 sub feed_article { #-# 1.2.01k
293 # load article from disk
295 open(ARTICLE,"<$file") or op(15,"I/O ERROR while opening $file: $!\n");
297 $wholeheader = <ARTICLE>; # $wholeheader is global!
298 @header = split(/\n/,$wholeheader); # @header is global!
300 $wholebody = <ARTICLE>; # $wholebody is global!
307 # check article and generate followup
308 my($testgroup,$auto)=@_;
309 # $testgroup is 'none' for forced check, '' for feeding-mode
310 # $auto is '2' for forced check, '' for feeding-mode
311 # will use global $wholeheader, @header and $wholebody (from &get_article / &feed_article)
312 # will use global %config and %domain (from &readrcfile / &readdomains)
313 my(@body); # parts of the posting
314 my($newsreader,$nr); # specials
315 my($docheck,$sigokay); # trigger
316 my(@article,@duplicate,$frdompart,$frlocpart,$rplocpart,$rpdompart,$wrongsig);
318 my($m,$f,$i,$flag,$sigstart,$query,$res,@mx,$key,$value,$testgroup_q,$postgroups);
320 my($tag,$monat,$jahr,$zeit,$wtag); # date
321 # will use global %header,%header_decoded,$debugmsg,%diag,$diaglevel
323 undef %header_decoded;
331 ($f = $config{$i}) =~ s/(\$[a-z{}'_-]+)/$1/gee;
335 # split $wholeheader into single headers
336 while ($_=shift @header) {
339 $_ =~ s/^\s*(.+)\s*$/$1/;
340 $header{lc($key)} .= "\n\t$_";
341 } elsif ($_ ne "\n") {
342 ($key,$value) = split /:/,$_,2;
343 if (exists $header{lc($key)}) {
344 push @duplicate,$key;
345 $diag{'duplicate'} = 1;
347 ($header{lc($key)} = $value) =~ s/^\s*(.+)\s*$/$1/;
352 # return if not a test group
353 # or if posting is bot-reply or cmsg or keywords contain $trigger_ignore ...
355 return if $header{'newsgroups'}!~/test/i;
356 return if $header{'message-id'} =~ /checkbot\.fqdn\.de>[ ]*$/i;
357 return if $header{'message-id'} =~ /checkbot-checked/i;
358 return if (defined($header{'control'}));
359 return if (defined($header{'keywords'}) and $header{'keywords'}=~/$trigger_ignore/io);
362 if ($feedmode) { #-# 1.2.01k
363 $auto = 3; # set $auto to unusual value
364 foreach $testgroup (@testgroups) {
365 $testgroup_q = quotemeta($testgroup); # quote meta characters ('.'!)
366 if ($header{'newsgroups'} =~ /$testgroup_q/) { # if one of the test groups is found in Newsgroups: ...
367 if ($postgroups != '') {
370 $postgroups .= $testgroup; # ... add it to $postgroups and ...
371 if ($auto{$testgroup} <= $auto) {
372 $auto = $auto{$testgroup}; # ... reset $auto to the lowest value of all testgroups
376 return if $auto == 3; # return if $auto was not reset
377 $testgroup = $postgroups; # set $testgroup for posting a followup
380 $debugmsg .= " --- Posting Check Results ---\n";
381 # ... or if killfile is triggered (if check is not forced) ...
383 $debugmsg .= " Checking posting; it's in a test group and neither bot-reply nor cmsg.\n";
384 # check if killfile is triggered and set $flag
386 ($key,$value) = @{$_};
387 if (defined($header{$key}) and $header{$key}=~/$value/i) {
389 $debugmsg .= " Killfile rule '$key=$value' triggered.\n";
394 # ... or if neither $trigger_check in Subject: nor auto-mode activated
395 $debugmsg .= " Subject: " . $header{'subject'} . "\n";
396 if ($header{'subject'} ne &hdecode($header{'subject'})) {
397 $debugmsg .= " Subject (decoded): " . &hdecode($header{'subject'}) . "\n";
399 if (&hdecode($header{'subject'}) =~ /$trigger_check/io or ($auto==2)) {
402 $debugmsg .= " TRIGGER: Check forced via '-c'.\n";
403 $testgroup = $header{'newsgroups'};
405 $debugmsg .= " TRIGGER: Found \"$trigger_check\" in the \"Subject:\"-line, continuing check.\n";
409 $debugmsg .= " TRIGGER: \"$trigger_check\" not found in \"Subject:\"-line";
410 if (!$auto or (&hdecode($header{'subject'}) =~ /$trigger_ignore/io) or $flag) {
411 $debugmsg .= ", terminating check.\n";
412 $debugmsg .= " --- End of Check Results ---\n\n";
413 op(15,"$header{'message-id'}:\n$debugmsg\n");
416 $debugmsg .= "; auto-mode activated - no ignore, continuing check.\n";
420 # put decoded (q/p and base64) headers in %header_decoded
421 foreach $key (keys %header) {
422 $header_decoded{$key} = &hdecode($header{$key});
425 # generate debugmsg for duplicate headers
426 foreach (@duplicate) {
427 $debugmsg .= " $debugdiagmarker Duplicate header line: $_\n"
430 # try to detect the newsreader
431 if (defined($header{'user-agent'})) {
432 $newsreader=$header_decoded{'user-agent'}
433 } elsif(defined($header{'x-newsreader'})) {
434 $newsreader=$header_decoded{'x-newsreader'}
435 } elsif (defined($header{'x-mailer'})) {
436 $newsreader=$header_decoded{'x-mailer'}
438 if ((defined($newsreader)) and ($newsreader ne '')) {
440 $nr= 'oe', last KNOWN if $newsreader=~/Outlook Express/i;
441 $nr= 'moz', last KNOWN if ($newsreader=~/Mozilla/i and $newsreader!~/StarOffice/i);
442 $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\@/);
443 $nr= 'xnews', last KNOWN if ($newsreader=~/Xnews/ or $header{'message-id'}=~/^$lt_alpha_num{6}\.$lt_alpha_num{2}\.\d\@/); #-# 1.2.01l
444 $nr= 'gnus', last KNOWN if ($newsreader=~/Gnus/i or $header{'message-id'}=~/^$lt_alpha_num{10,11}\.fsf\@/o);
445 $nr= 'slrn', last KNOWN if ($newsreader=~/slrn/i or $header{'message-id'}=~/^slrn$lt_alpha_num{6}\.$lt_alpha_num{2,3}\.\w+\@/);
446 $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\.]+\@/);
447 $nr= 'mpg', last KNOWN if ($newsreader=~/Gravity/i or $header{'message-id'}=~/^MPG\.$lt_hex_nibb{22}\@/o);
448 $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);
449 $nr= 'xp', last KNOWN if ($newsreader=~/Gravity/i or $header{'message-id'}=~/^[a-zA-Z0-9\$\-]{11}\@/o);
450 $nr= 'pminews', last KNOWN if ($newsreader=~/Gravity/i or $header{'message-id'}=~/^[a-z]{16,21}\.$alpha_num{7}\.pminews\@/o);
455 $debugmsg .= " Could not identify newsreader.\n"
457 $debugmsg .= " Newsreader identified: $newsreader [$nr].\n"
460 # * ---> check for 8bit in headers
461 if($wholeheader=~/[\x80-\xFF]/) {
462 $diag{'8bitheader'}=1;
464 $debugmsg .= " $debugdiagmarker 8bit-chars in header.\n";
467 # * ---> check from-header
468 ($frlocpart,$frdompart) = checkfromrp('From');
470 # * ---> check reply-to
471 if (defined($header{'reply-to'})) {
472 ($rplocpart,$rpdompart) = checkfromrp('Reply-To');
475 # * ---> check from == replyto
476 if(defined($header{'reply-to'}) && ((getmailaddress($header_decoded{'from'}))[0] eq (getmailaddress($header_decoded{'reply-to'}))[0])) {
477 $diag{'replytofrom'}=1 ;
479 $debugmsg .= " $debugdiagmarker \"From:\" = \"Reply-To:\".\n";
482 # * ---> check message-id
483 ($dompart = $header{'message-id'}) =~ s/.*\@(.*)>$/$1/; # fqdn isolieren
484 $dompart = lc($dompart);
485 ($tld = $dompart) =~ s/.*\.([^.]+)$/$1/; # TLD isolieren
486 # no FQDN, but less than one word or numbers
487 if($dompart!~/(\D\w*\.)+(\D\w*$)/) {
490 $debugmsg .= " $debugdiagmarker MID wrong: FQDN is just one word or just numbers.\n";
492 # invalid chars in domain
493 if($dompart =~ /[^a-z0-9\-.]/) {
496 $debugmsg .= " $debugdiagmarker MID wrong: FQDN contains invalid characters.\n";
498 # check for valid TLD
499 if(!defined($domain{$tld})) {
502 $debugmsg .= " $debugdiagmarker MID wrong: no valid TLD.\n";
504 # check for <unique%mailaddress@do.main> (USEFOR, used e.g. by MacSOUP)
505 ($f,undef,undef,$i,undef) = &getmailaddress($header_decoded{'from'});
507 if ($header{'message-id'} =~ /%$f>$/) {
508 $debugmsg .= " MID is <unique%address\@do.main>, see draft-ietf-usefor-msg-id-alt-00,\n";
509 $debugmsg .= " chapter 2.1.2 - not yet a good idea (but we do not mind ;-)).\n";
510 } elsif (($dompart eq $i) and ($nr eq 'moz') and ($header{'message-id'} =~ /^<$gt_hex_nibb{8}\.$gt_hex_nibb{4,8}\@/)) {
511 # Mozilla generates the MID from the FQDN of the mailaddress
514 $debugmsg .= " $debugdiagmarker MID wrong: Mozilla takes FQDN of mailaddress.\n";
515 } elsif($dompart=~/^gmx\.(de|net|at|ch|li)$/) {
516 # special: GMX does not offer usenet service
519 $debugmsg .= " $debugdiagmarker MID wrong: GMX does not offer usenet service.\n";
521 if (defined($diag{'nomid'})) {
522 $debugmsg .= " MID was \"$header{'message-id'}\".\n";
526 ($wtag,$tag,$monat,$jahr,$zeit) = (split / +/, $header{'date'});
527 if (!($wtag=~/\w{3},/)) {
536 $debugmsg .= " $debugdiagmarker \"Date:\" is incorrect: year < 1970.\n";
537 $debugmsg .= " \"Date:\" was: \"$header{'date'}\".\n";
540 # * ---> check for html
541 if(defined($header{'content-type'})&&$header{'content-type'}=~/html/i) {
544 $debugmsg .= " $debugdiagmarker HTML detected (no multipart/alternative!).\n";
547 # * ---> check for multiparts
548 if(defined($header{'content-type'}) and ($header{'content-type'}=~/multipart/)) {
549 $diag{'multipart'}=1;
551 $debugmsg .= " $debugdiagmarker MIME-multipart identified.\n";
552 $debugmsg .= " Cannot check body of that posting - do not understand multipart yet.\n";
555 # apply checks to body only if there _is_ a body
556 if (defined($wholebody)) {
557 if(defined($header{'content-transfer-encoding'})) {
559 # * ---> check for q/p (body)
560 if ($header{'content-transfer-encoding'}=~/quoted/i){
561 # $diag{'qp'}=1; #-# 1.2.01k
562 # $diaglevel ||= 1; #-# 1.2.01k
563 # $debugmsg .= " $debugdiagmarker Content-transfer-encoding: quoted/printable.\n"; #-# 1.2.01k
564 $debugmsg .= " Content-transfer-encoding: quoted/printable.\n";
565 $debugmsg .= " Will decode that body now.\n";
566 # convert quoted-printables to 8bit
567 # $wholebody=~s/[ \t]\n/\n/sg; # RFC 1521 5.1 Rule #3
568 $wholebody=~s/=\n//sg; # RFC 1521 5.1 Rule #5
569 $wholebody=~s/=([0-9a-fA-F]{2})/pack("H2",$1)/sge;
572 # * ---> check for base64 (body)
573 if($header{'content-transfer-encoding'}=~/base64/i){
576 $debugmsg .= " $debugdiagmarker Content-transfer-encoding: Base64.\n";
577 $debugmsg .= " Will decode that body now.\n";
578 $wholebody = decode_base64($wholebody); # do Base64-decoding
582 # split $wholebody into single lines
583 @body=split("\n",$wholebody);
585 # terminate and return if $trigger_ignore is found in first line
586 # (and $trigger_check not in Subject:) --> $docheck
587 if (!$docheck and ($body[0] =~ /$trigger_ignore/io)) {
588 $debugmsg .= " TRIGGER: \"$trigger_ignore\" found in \"Subject:\"-line or first line of posting; terminating check.\n";
589 $debugmsg .= " --- End of Check Results ---\n\n";
590 op(15,"$header{'message-id'}:\n$debugmsg\n");
594 # * ---> check for charset / transfer-encoding
595 if(!defined($diag{'multipart'})) {
596 if($wholebody=~/[\x80-\xff]/){
597 # (@problem) = $wholebody=~/([\x80-\xff])/g;
598 $debugmsg .= " Found 8bit-characters in body.\n";
599 # $debugmsg .= " @problem\n";
600 if(defined($header{'content-type'})){
601 if($header{'content-type'}!~/charset=/i){
602 $diag{'nocharset'}=1;
604 $debugmsg .= " $debugdiagmarker Header \"Content-Type:\" does not define charset.\n";
606 if($header{'content-type'}=~/us-ascii/) {
607 $diag{'nocharset'}=1;
609 $debugmsg .= " $debugdiagmarker Charset is \"US-ASCII\".\n";
612 $diag{'nocharset'}=1;
614 $debugmsg .= " $debugdiagmarker No charset defined.\n";
616 if(!defined($header{'content-transfer-encoding'})) {
617 $diag{'nocontenttransferenc'}=1;
619 $debugmsg .= " $debugdiagmarker No content-transfer-encoding defined.\n";
624 # * ---> check for vcards
625 if($wholebody=~/(^begin:vcard\s*$)(.|[\n])+(^end:vcard\s*$)/im) {
628 $debugmsg .= " $debugdiagmarker V-Card identified.\n";
632 # sig-delimiter and (too) long sigs
633 for($i=$#body;$i>-1;$i--){ #-# 1.2.01i: fixed sigdelimiter first line
634 if (defined($diag{'base64'})) {
635 $body[$i] =~ s/\r$//; # remove carriage returns (CR-CR-LF to CR-LF)
637 if($body[$i]=~/^(- )?--[^-]?\s*$/){
639 $debugmsg .= " Possible sig-delimiter found in line " . ($i+1) . " of posting.\n";
640 if ($body[$i] !~/^(- )?-- $/ and $sigokay == 0) {
641 $diag{'sigdelimiter'} = 1;
642 $wrongsig = $body[$i];
643 $debugmsg .= " $debugdiagmarker Sig-delimiter in line " . ($i+1) . " is wrong.\n";
644 $debugmsg .= " Sig-delimiter was \"$wrongsig\".\n";
647 $debugmsg .= " Sig-delimiter is correct or not checked.";
648 if ($diag{'sigdelimiter'} == 1) {
649 delete $diag{'sigdelimiter'};
650 $debugmsg .= " - Reset error-message.\n";
652 $debugmsg .= "\n"; };
662 $debugmsg .= " $debugdiagmarker Sig is too long [starting line ".($f+2)." - ending line ".($#body+1)."].\n";
666 if ($diag{'sigdelimiter'} == 1) {$diaglevel ||= 1;};
670 for ($i=$sigstart; $i>=0; $i--) {
671 last LINECHECK if(!defined($body[$i]));
672 if(($body[$i]=~/^.{75,}$/) and ($body[$i]!~/^[ ]*[>|:]/)) {
673 $diag{'longlines'}=1;
675 $debugmsg .= " $debugdiagmarker Line " . ($i+1) . " too long and not quoted.\n";
676 $debugmsg .= " Offending line: " . $body[$i] . "\n";
680 if ($sigstart < $#body) {
682 for ($i=$sigstart; $i<=$#body; $i++) {
683 last SIGCHECK if(!defined($body[$i]));
684 if($body[$i]=~/^.{81,}$/) {
685 $diag{'longlinesig'}=1;
687 $debugmsg .= " $debugdiagmarker Line " . ($i-$sigstart) . " of signature too long.\n";
688 $debugmsg .= " Offending line: " . $body[$i] . "\n";
693 $debugmsg .= " Message does not contain body.\n"
696 # if config for any problem is empty (.rc-file!), reset diag
697 foreach $i (keys %diag) {
698 if(!defined($config{$i}) and defined($diag{$i})) {
700 $debugmsg .= " ! Configuration: Text for [$i] missing - problem was found, but won't be reported.\n";
704 # increase diaglevel if pedantic is on
705 if ($pedantic) { $diaglevel += 1; };
707 $debugmsg .= " --- End of Check Results ---\n\n";
709 # if subject == 'check' or auto == 1 and $diaglevel > 1:
711 if ($docheck or ($auto && ($diaglevel > 1))) {
712 op(2,"Got one! ---> $header{'message-id'}\n");
713 op(2,"Generating followup, writing to $testgroup ...");
715 @article = $config{'head'};
716 push @article, "Newsgroups: $testgroup\n";
717 ($m=$header{'message-id'})=~s/\@(.*)>$/%$1/;
718 push @article, 'Message-ID: '.$m.'@checkbot.fqdn.de>'."\n";
719 if(defined($header{'references'})) {
720 push @article, "References: $header{'references'} $header{'message-id'}\n"
722 push @article, "References: $header{'message-id'}\n"
724 ($wtag,$monat,$tag,$zeit,$jahr) = (split / +/, (scalar gmtime));
725 push @article, "Date: $wtag, $tag $monat $jahr $zeit GMT\n";
727 $f .= "Re: " unless ($header_decoded{'subject'}=~/^[ \t]*re:/i);
728 $f .= &encode_header($header_decoded{'subject'});
729 push @article, "$f\n";
730 push @article, "X-Artchk-Version: artchk.pl (mod.) $version\n";
731 if($header_decoded{'subject'}=~/(^|\s)replybymail(\s|$)/) {
732 push @article, "X-Sorry: 'replybymail' not supported in this version.\n";
735 push @article, "X-Comment: Check enforced by operator using '$0 -c'.\n";
737 push @article, "MIME-Version: 1.0\n";
738 push @article, "Content-Type: text/plain; charset=ISO-8859-1\n";
739 push @article, "Content-Transfer-Encoding: 8bit\n";
742 push @article, $config{'header-forced'}
744 push @article, $config{'header'}
746 push @article, $config{'header-auto'}
748 push @article, "\nCHECKBOT INTERNAL ERROR!\n"
751 push @article, "$header_decoded{'from'} schrieb:\n\n";
752 if(scalar @body==0){push @article, "[nichts]\n\n"}
753 else{for(0..4){push @article, '>'.$body[$_]."\n" if defined $body[$_]}}
754 push @article, "[...]\n" if (defined($body[5]));
757 if(scalar keys %diag !=0){
758 push @article, $config{'intro'},"\n";
759 if (defined($diag{'duplicate'}) && $diag{'duplicate'}==1) {
760 push @article, $config{'duplicate'},"\n";
761 while ($_=shift @duplicate) {
762 push @article, "| $_\n";
764 push @article, "\n"; #-# 1.2.01k
766 foreach $i (qw/from from-domain from-roles noname reply-to reply-to-domain reply-to-roles replytofrom date
767 nomid 8bitheader nocharset nocontenttransferenc sigdelimiter longsig
768 multipart base64 html vcard longlines longlinesig /){ #-# 1.2.01k: removed qp
769 if (defined($diag{$i}) && $diag{$i}==1) {
770 push @article, ev($i), "\n"; # Variablen expandieren
772 if (defined($config{"$i-$nr"}) && $diag{$i}==1) {
773 push @article, ev("$i-$nr"), "\n"; # Variablen expandieren
776 if (defined($config{'umlauts'})) {
777 push @article, $config{'umlauts'},"\n" if((defined($diag{'nocharset'})) && ($diag{'nocharset'}==1) or
778 (defined($diag{'8bitheader'})) && ($diag{'8bitheader'}==1));
780 if (defined($config{'violation'}) && $diaglevel > 1) { #-# 1.2.01k
781 push @article, "$config{'violation'}\n";
783 push @article, $config{'nr'},"\n";
784 if (defined($nr) and (defined($config{$nr}))) {
785 push @article, ev('nr-known'), "\n"; # Variablen expandieren
786 push @article, ev($nr), "\n"; # Variablen expandieren
788 if (defined($header{'x-trace'}) and ($header{'x-trace'}=~/^fu-berlin.de/) and defined($config{'newscis'})) {
789 push @article, "$config{'newscis'}\n";
792 push @article, $config{'allok'},"\n";
795 if ($header_decoded{'subject'}=~ /$trigger_check verbose/io) {
796 push @article, $config{'debug'};
797 ($f=$debugmsg)=~s/\n/\n\| /g;
798 $f = '| ' . $f . "\n\n";
802 push @article, $config{'footer'};
804 if ($feedmode) { #-# 1.2.01k ---->
805 # open server for posting
806 if ($postingserver ne '') {
807 $postserver = &connectserver($postingserver,$postingport,$posts_user,$posts_pass)
809 $postserver = &connectserver($server,$port,$s_user,$s_pass);
812 } else { #-# 1.2.01k <-----
813 if ($postingserver ne '') {
815 $i = "$postingserver";
816 if ($postingport ne '') {
817 $i .= "(Port $postingport)";
823 $i .= " (Port $port)";
827 if (!($$f->post(@article))) { #-# 1.2.01g
828 op(13,"\n$serverresponse Error: " . $$f->code . ' ' . $$f->message);
829 op(0,"Error writing followup to $i.\n");
830 if ($$f->message =~ /imeout/ and $postingserver ne '') {
831 op(10,"Retry due to timeout ...");
832 $postserver = &connectserver($postingserver,$postingport,$posts_user,$posts_pass);
833 if (!($postserver->post(@article))) {
834 op(13,"\n$serverresponse Error: " . $$f->code . ' ' . $$f->message);
835 op(0,"Error writing followup to $i during retry.\n");
837 op(2," done (written to $i).\n");
838 op(2,"Message-ID was $m\@checkbot.fqdn.de>.\n");
839 op(3,"$serverresponse".$postserver->code.' '.$postserver->message);
843 op(2," done (written to $i).\n");
844 op(2,"Message-ID was $m\@checkbot.fqdn.de>.\n");
845 op(3,"$serverresponse".$$f->code.' '.$$f->message);
847 if ($feedmode) { #-# 1.2.01k
850 op(14,"\n$header{'message-id'}:\n$debugmsg\n\n");
852 op(15,"$header{'message-id'}:\n$debugmsg\n");
856 ################################################################
857 # Subroutines: get_mail_address
858 # encode_header / hdecode / dodecode
860 # generic output routinte (instead of 'print')
865 my($tmp,$address,$name,$lp,$dp,$type);
866 if($raw=~/^<?($r_address)>?$/) {
870 } elsif($raw=~/^($r_address)\s+\($r_paren_phrase\)\s*$/) {
873 $tmp = quotemeta($address);
874 ($name = $raw) =~ s/^$tmp\s+\(([^()]+)\)$/$1/;
875 } elsif($raw=~/^(($r_quoted_word|$r_unquoted_word)(\s+($r_quoted_word|$r_unquoted_word))*)\s+<$r_address>\s*$/) {
878 ($address = $raw) =~ s/.*<($r_address)>\s*$/$1/;
880 ($lp = $address) =~ s/^([^@]+)@.*/$1/;
881 ($dp = $address) =~ s/\S*\@(\S*)$/$1/;
882 chomp ($address, $name, $lp, $dp, $type);
883 foreach $tmp ($address, $name, $lp, $dp, $type) {
886 return $address, $name, $lp, $dp, $type;
890 # * ---> check from-header / reply-to
891 my ($headername) = shift;
892 my $hname = lc($headername);
893 my($address,$name,$locpart,$dompart,$type)=&getmailaddress($header_decoded{$hname});
895 ($tld = $dompart) =~ s/.*\.([^.]+)$/$1/; # isolate TLD
897 if ($hname eq 'from') {
899 $debugmsg .= " \"From:\"-header is type 1 [address\@do.main].\n";
901 $debugmsg .= " \"From:\"-header is type 2 [address\@do.main (full name)].\n";
903 $debugmsg .= " \"From:\"-header is type 3 [full name <address\@do.main>].\n";
907 $debugmsg .= " $debugdiagmarker \"From:\"-syntax is incorrect.\n";
913 $debugmsg .= " $debugdiagmarker \"Reply-To:\" is incorrect.\n";
917 if($f =~ /[^a-z0-9\-.]/) {
920 $debugmsg .= " $debugdiagmarker \"$headername:\" is incorrect: invalid chars in domain.\n";
924 if(!defined($domain{$tld})) {
925 $diag{"$hname".'-domain'}=1;
927 $debugmsg .= " $debugdiagmarker \"$headername:\" is incorrect: no valid TLD.\n";
931 $res = Net::DNS::Resolver -> new();
933 $res->tcp_timeout(15);
934 $i='okay'; #-# 1.2.01i: fixed 'bug' in logging DNS-checks
935 @mx = mx($res,$dompart) or $i = $res->errorstring;
936 $debugmsg .= " DNS (\"$headername:\"): $i.\n"; #-# 1.2.01i: fixed 'bug' in logging DNS-checks
937 if ($i eq 'NXDOMAIN' or $i eq 'NOERROR') {
938 $debugmsg .= " No MX-record for \"$dompart\": $i.\n";
939 $i='okay'; #-# 1.2.01i: fixed 'bug' in logging DNS-checks
940 $query = $res->search($dompart) or $i = $res->errorstring;
941 $debugmsg .= " DNS (\"$headername:\"): $i.\n"; #-# 1.2.01i: fixed 'bug' in logging DNS-checks
942 if ($i eq 'NXDOMAIN' or $i eq 'NOERROR') {
943 $debugmsg .= " $debugdiagmarker No A-record either: $i - \"$headername:\" is not replyable.\n";
944 $diag{"$hname".'-domain'}=1;
950 # no name, just address?
951 if ($hname eq 'from') {
952 if($name !~ /[a-z][^.]\S*\s+\S*([a-z][^.]\S*)+/i) {
955 $debugmsg .= " $debugdiagmarker \"From:\" does not contain full name.\"\n";
958 # check for role accounts
959 ROLES: foreach $f (@roles) {
960 if ($f eq lc($locpart)) {
961 $diag{"$hname".'-roles'}=1;
963 $debugmsg .= " $debugdiagmarker \"$headername:\" contains role account.\"\n";
968 if (defined($diag{$hname}) or defined($diag{"$hname".'-domain'}) or defined($diag{"$hname".'-roles'}) or ($debuglevel > 4)) {
969 $debugmsg .= " \"$headername:\": \"$header{$hname}\".\n";
970 if ($header{$hname} ne $header_decoded{$hname}) {
971 $debugmsg .= " \"$headername:\" (decoded): \"$header_decoded{$hname}\".\n";
973 } elsif (defined($diag{'noname'}) and ($hname eq 'from')) {
974 $debugmsg .= " \"From:\": \"$header{'from'}\".\n";
975 if ($header{'from'} ne $header_decoded{'from'}) {
976 $debugmsg .= " \"From:\" (decoded): \"$header_decoded{'from'}\".\n";
979 return ($locpart,$dompart);
984 my ($word,$space,$encoded_header);
985 while ($header=~/(\S+)(\s*)/g) {
986 ($word,$space) = ($1,$2);
987 if ($word=~/[\x80-\xFF]/) {
988 $word='=?iso-8859-1?Q?'.encode_qp($word).'?=';
990 $encoded_header .= "$word$space";
992 $encoded_header =~ s/\?=(\s+)=\?iso-8859-1\?Q\?/$1/g;
993 return $encoded_header;
999 if ($header=~/=\?.*\?(.)\?(.*)\?=/) {
1000 $header=~s/=\?.*\?(.)\?(.*)\?=/&dodecode($1,$2)/ge;
1002 $header=~s/\n\t//; # unfold headers
1008 # decode RFC 1522 headers
1013 $etext=decode_qp($etext);
1015 }elsif($enc=~/^b$/i){
1016 $etext=decode_base64($etext);
1024 # level 0 : error messages, introduction/end
1025 # level 1 (-v) : + configuration and summaries
1026 # level 2 (-vv) : + progress indicator
1027 # level 3 (-vvv) : + NNTP-replies from server(s)
1028 # level 4 (-vvvv) : + debug-output from check-routines
1029 # level >=10 : output also to logfile if activated
1030 my($level,$text,$handle) = @_;
1032 if ($logging) { print LOG $text; };
1035 $handle ||= 'STDOUT';
1036 if ($debuglevel >= $level and not $feedmode) {
1037 print $handle $text;
1044 my($server,$port,$s_user,$s_pass) = @_;
1047 op(0,"Connecting to news server ...");
1048 my $c = new News::NNTPClient($server,$port);
1051 op(0,"\nCan't connect to server. Aborting.\n");
1052 die "\nCan't connect to server. Aborting.\n";
1057 $c->postok() or op(0,"Server does not allow posting?!\n");
1059 op(3,"$serverresponse".$c->code.' '.$c->message);
1061 # switch off error messages from News::NNTPClient
1065 op(1,'MODE reader ...');
1066 if (!($c->mode_reader)) {
1067 op(10,"\n$serverresponse Error: " . $c->code . ' ' . $c->message . "Aborting.\n");
1068 die '$serverresponse Error: ' . $c->code . ' ' . $c->message . "Aborting.\n";
1071 op(3,"$serverresponse".$c->code.' '.$c->message);
1074 # authorize, if needed
1075 if ($s_user ne '') {
1076 op(1,"Authentification ...");
1077 if ($c->authinfo($s_user,$s_pass)) {
1080 op(0,"\nAuthentification failure. Aborting.\n");
1081 die "\nAuthentification failure. Aborting.\n";
1083 op(3,"$serverresponse", $c->code, ' ', $c->message);
1091 ################################################################
1092 # Subroutines for reading / writing files
1099 open(RC,'<'.$pathtoini.$rcname.'.rc')||die "Could not open $pathtoini"."$rcname.rc for reading: $!";
1103 next if(substr($i,0,1) eq ';');
1104 if($i=~/^\[.*\]$/){ $a=substr($i,1,-2);next; }
1108 # check for _necessary_ entries
1109 foreach $i (qw/head header header-auto footer intro allok nr debug/) {
1110 if(!defined($config{$i})){
1111 op(0,"The entry [$i] is missing in the $rcname.rc file. This entry\n");
1112 op(0,"is necessary.\n");
1116 # check for other entries
1117 foreach $i (qw/multipart html vcard nocharset nocontenttransferenc base64 nomid
1118 nomid-moz longlines longlinesig 8bitheader replytofrom reply-to sigdelimiter
1119 sigdelimiter-oe date from noname longsig umlauts nr-known oe moz agent
1120 xnews gnus macsoup slrn newscis from-domain from-roles reply-to-domain reply-to-roles/) { #-# 1.2.01k: removed qp
1121 if(!defined($config{$i})){
1122 op(0,"\n.rc: The entry [$i] is missing in the $rcname.rc file.\n");
1123 op(0," Corresponding check will be skipped.\n");
1131 open(INI,'<'.$pathtoini.$ininame.'.ini')||die "Could not open $pathtoini"."$ininame.ini for reading: $!";
1134 if ($c=~/=/) { # if '=' is found in line
1135 chomp(($a,$b)=split(/=/,$c)); # split it into parametername and -contents
1136 $a=~s/^\s*(.*?)\s*$/$1/g; # delete leading/trailing whitespace
1137 $b=~s/^\s*(.*?)\s*$/$1/g; # delete leading/trailing whitespace
1138 if ($a eq 'reader') {
1139 chomp(($server,$port)=split(/,/,$b));
1140 } elsif ($a eq 'reader_user') {
1142 } elsif ($a eq 'reader_pass') {
1144 } elsif ($a eq 'poster') {
1145 chomp(($postingserver,$postingport)=split(/,/,$b));
1146 } elsif ($a eq 'poster_user') {
1147 chomp($posts_user=$b);
1148 } elsif ($a eq 'poster_pass') {
1149 chomp($posts_pass=$b);
1150 } elsif ($a eq 'trigger_check') {
1151 chomp($trigger_check=$b);
1152 } elsif ($a eq 'trigger_ignore') {
1153 chomp($trigger_ignore=$b);
1154 } elsif ($a eq 'rcfile') {
1156 } elsif ($a eq 'killfile') {
1157 chomp($killname=$b);
1159 } elsif ($c =~/checkgroups:/) {
1161 chomp(($a,$b,$c)=split(/ /,<INI>));
1162 @testgroups = (@testgroups, $a) unless ($a!~/^\w+(\.\w+)+/);
1168 $watermark{$a} = $c;
1169 if (!defined($watermark{$a})) {$watermark{$a} = 0};
1175 op(0,"You have to define a reading server in $ininame.ini\n");
1178 if($trigger_check eq '') {
1179 $trigger_check='check';
1181 if($trigger_ignore eq '') {
1182 $trigger_ignore='(ignore)|(no[ ]*repl(y|(ies)))|(nocheck)';
1186 } elsif ($rcname=~/\.rc$/) {
1187 $rcname=~s/(.*?)\.rc$/$1/;
1189 if($killname eq '') {
1191 } elsif ($killname=~/\.kill$/) {
1192 $killname=~s/(.*?)\.kill$/$1/;
1194 if(scalar(@testgroups) == 0) {
1195 op(0,"You have to define at least one testgroup in $ininame.ini\n");
1203 open(INI,'<'.$pathtoini.$ininame.'.ini')||die "Could not open $pathtoini"."$ininame.ini for reading: $!";
1207 if ($r =~/checkgroups:/) {
1212 open(INI,'>'.$pathtoini.$ininame.'.ini')||die "Could not open $pathtoini"."$ininame.ini for writing: $!";
1214 foreach $testgroup (@testgroups) {
1215 print INI "$testgroup ";
1216 if ($auto{$testgroup} == 0) {
1221 print INI "$watermark{$testgroup}\n";
1229 open(DOM,'<'.$pathtoini.'domains')||die "Could not open \"$pathtoini"."domains\" for reading: $!";
1230 chomp(@domains = split(/ /,<DOM>));
1233 until(!defined(@domains[$i])) {
1234 $domain{$domains[$i]} = 'valid';