projects / usenet / artchk.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit.
[usenet/artchk.git] / artchk.pl
CommitLineData
353fe932
TH		 1#!/usr/bin/perl
2#
3# Automatic Article Checker
4# v1.6 Copyright (C) June 2, 1999 by Heinrich Schramm
5# mailto:heinrich@schramm.com
6#
7# converted to perl by Wilfried Klaebe <wk@orion.toppoint.de>
8# (not really converted, more or less rewritten in perl)
9#
10# modified & enhanced
11# by Thomas Hochstein <THochstein@gmx.de> since March/April 2000
12# (c) artchk.pl (mod.) January 06, 2001 by Thomas Hochstein
13#
14# _________ ATTENTION please! - This is still a BETA version! _________
15#
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)
20# any later version.
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
24# more details.
25# ------------------------------------------------------------------------------
26#
27# You will need the following modules from CPAN:
28# - News::NNTPClient
29# - MIME::QuotedPrint
30# - MIME::Base64
31# (- Net::DNS)
32#
33# ------------------------------------------------------------------------------
34#
35# You will have to create an artchk.pl.ini / artchk.pl.rc file.
36# Please see readme.txt for details.
37#
38# Please use this program with care and sense of responsibility!
39# Thank you.
40#
41##################################################################
42
43###-### mark for temp. changes
44#-# 1.2.01g changes new in that version
45#-# {RKELLER} Contributed by Reiner Keller <keller@dlrg.de>
46
47use News::NNTPClient;
48use MIME::QuotedPrint;
49use MIME::Base64;
50use Net::DNS;
51use File::Basename; #-# {RKELLER}
52
53##### Constants
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)*";
79
80##### Main program
81# get commandline parameters
82while (@ARGV) {
83 $f = shift;
84 if ($f =~ /^-d(.*)/) {
85 $debuglevel = $1;
86 } elsif ($f =~ /-(v+)/) {
87 $debuglevel = length($1);
88 } elsif ($f =~ /-p(.*)/) {
89 $pathtoini = $1;
90 } elsif ($f =~ /-n(.*)/) {
91 $ininame = $1;
92 if ($ininame=~/\.ini$/) {
93 $ininame=~s/(.*?)\.ini$/$1/;
94 };
95 } elsif ($f =~ /-c(.*)/) {
96 $checkpost = $1;
97 } elsif ($f =~ /^-l(.*)/) {
98 $logfile = $1;
99 if ($logfile =~/\.log$/) {
100 $logfile=~s/(.*?)\.log$/$1/;
101 };
102 } elsif ($f =~ /--log/) {
103 $logging = 1;
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
108 }
109};
110
111# set parameters to default, if necessary / exit, if disabled
112if (!defined($debuglevel)) {$debuglevel = 0};
113if (!defined($ininame)) {$ininame = basename ($0)}; #-# {RKELLER}
114exit (10) if (-e "$0.disabled"); # exit if "artchk.pl.disabled" exists
115exit (10) if (-e "$ininame.disabled"); # exit if ".disabled" exists
116if (!defined($pathtoini)) {
117 $pathtoini = dirname ($0).'/' #-# {RKELLER}
118} elsif ($pathtoini !~ /.*(\/|\\)$/) {
119 $pathtoini .= '/';
120}
121if (!defined($checkpost) or ($checkpost!~/<\S+\@\S+>/)) {$checkpost = 'no'};
122if (!defined($logfile)) {$logfile = "$ininame"};
123
124# open logfile
125if ($logging) {
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
129 };
130};
131
132# print introduction
133op(10,"\n-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-\n\n");
134op(10,"This is artchk.pl (mod.) $version started on ".scalar(gmtime)." GMT.\n");
135op(0,"Send suggestions & comments to <artchk\@akallabeth.de>.\n\n");
136
137# read .rc-file / .ini-file / domains / killfile
138&readini;
139&readrcfile;
140&readdomains;
141if (-e "$killname.kill") {
142 open KILL, "<$pathtoini$killname.kill" || die "Could not open $pathtoini$killname.kill for reading: $!";
143 while (<KILL>) {
144 chomp;
145 s/#.+//; # drop comments
146 s/^\s+//; # drop whitespace before
147 s/\s+$//; # drop whitespace after
148 next unless length;
149 my ($key,$value) = split(/\s*=\s*/,$_,2); # header = regexp
150 push @{ $kill[scalar(@kill)] },lc($key),lc($value);
151 };
152 close KILL;
153};
154
155# print configuration
156op(1,"\nDebug-Level : $debuglevel\n");
157op(1, "Path to files : $pathtoini\n");
158op(1, "Filenames : $ininame.ini / $rcname.rc / $logfile.log\n");
159op(1, "Trigger 'check' : $trigger_check\n");
160op(1, "Trigger 'ignore' : $trigger_ignore\n");
161op(1, "Newsserver (read): $server $port\n");
162op(1, "Newsserver (post): $postingserver $postingport\n");
163if ($checkpost eq 'no') {
164 op(1, 'Groups to check :');
165 foreach $testgroup (@testgroups) {op(1, " $testgroup")};
166} else {
167 op(11, "Posting to check: $checkpost\n");
168};
169op(1, "\n\n");
170op(1, "---------- Starting connection procedure ----------\n");
171
172if ($feedmode) { #-# 1.2.01k ---->
173 until(eof(STDIN)){
174 $file=<STDIN>;
175 $file=~s/(\S*).*/$1/;
176 &feed_article($file); # will set $wholeheader, @header and $wholebody (global!)
177 &check_article;
178 }
179} else { #-# 1.2.01k <-----
180 # open server (for reading)
181 $readserver = &connectserver($server,$port,$s_user,$s_pass);
182
183 # open server (for posting), if specified
184 if ($postingserver ne '') { $postserver = &connectserver($postingserver,$postingport,$posts_user,$posts_pass) };
185
186 # main loop - check all postings in all groups
187 op(1,"---------- Starting checks ----------");
188
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");
197 } else {
198 op(1," done.\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;
204 }
205 if ($watermark{$testgroup} > $low) {$low = $watermark{$testgroup}};
206 if ($watermark{$testgroup} > $high) {
207 op(1,"Nothing new to check in $testgroup ... terminating.\n");
208 } else {
209 op(1,'Starting checks, ');
210 if($auto{$testgroup}) {
211 op(1,"generating followups for any problem detected (auto-mode).\n");
212 }else{
213 op(1, "only generating followups if requested.\n");
214 }
215 }
216
217 # load posting
218 for ($doit = $low; $doit <= $high; $doit += 1) {
219 $togo=$high-$doit;
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});
223 };
224
225 # remmber last tested posting
226 $watermark{$testgroup} = $high + 1;
227
228 # rewrite .ini-file
229 op(1,"Rewriting .ini-file ... ");
230 &writeini;
231 op(1,"done.\n");
232 };
233 }
234 } else {
235 op(1,"\nNow getting: $checkpost\n");
236 &get_article($checkpost); # will set $wholeheader and $wholebody (global!)
237 &check_article('none',2);
238 }
239
240 op(1,"\n\n---------- Termination sequence ... ----------");
241 op(1,"\nartchk.pl (mod.) $version signing off.\n");
242 # close server and files
243 $readserver->quit;
244 if ($postingserver ne '') { $postserver->quit };
245};
246
247if ($logging) {
248 op(15,"$0 $version terminated successfully on ".scalar(gmtime)." GMT.\n");
249 close LOG;
250};
251op(0,"Program terminated on ".scalar(gmtime)." GMT.\n\n");
252op(0,"Thank you for using.\n");
253exit(0);
254
255################################################################
256# Main subroutines: get article / feed article / check article
257
258sub get_article {
259# load article via NNTP
260 my($doit)=@_;
261 my(@article,$lang);
262
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");
267 } else {
268 op(3,"$serverresponse".$readserver->code.' '.$readserver->message);
269 };
270 # split @article and add all lines to $wholeheader
271 @header = @article; # @header is global!
272 $wholeheader = ''; # $wholeheader is global!
273 $lang = @article;
274 for ($i = 0; $i <= $lang; $i+= 1) {
275 $wholeheader .= shift(@article);
276 };
277 # ... then get body
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");
281 } else {
282 op(3,"$serverresponse".$readserver->code.' '.$readserver->message);
283 };
284 $wholebody = ''; # $wholebody is global!
285 $lang = @article;
286 for ($i = 0; $i <= $lang; $i+= 1) {
287 $wholebody .= shift(@article);
288 };
289};
290
291
292sub feed_article { #-# 1.2.01k
293# load article from disk
294 my $file = shift;
295 open(ARTICLE,"<$file") or op(15,"I/O ERROR while opening $file: $!\n");
296 $/='';
297 $wholeheader = <ARTICLE>; # $wholeheader is global!
298 @header = split(/\n/,$wholeheader); # @header is global!
299 undef $/;
300 $wholebody = <ARTICLE>; # $wholebody is global!
301 close(ARTICLE);
302 $/="\n";
303};
304
305
306sub check_article {
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);
317 # output
318 my($m,$f,$i,$flag,$sigstart,$query,$res,@mx,$key,$value,$testgroup_q,$postgroups);
319 # auxiliaries
320 my($tag,$monat,$jahr,$zeit,$wtag); # date
321 # will use global %header,%header_decoded,$debugmsg,%diag,$diaglevel
322 undef %header;
323 undef %header_decoded;
324 undef $debugmsg;
325 undef %diag;
326 undef $diaglevel;
327
328 local *ev = sub {
329 # evaluate variables
330 my ($i) = shift;
331 ($f = $config{$i}) =~ s/(\$[a-z{}'_-]+)/$1/gee;
332 $f;
333 };
334
335 # split $wholeheader into single headers
336 while ($_=shift @header) {
337 chomp;
338 if ($_ =~ /^\s+/) {
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;
346 } else {
347 ($header{lc($key)} = $value) =~ s/^\s*(.+)\s*$/$1/;
348 };
349 };
350 };;
351
352 # return if not a test group
353 # or if posting is bot-reply or cmsg or keywords contain $trigger_ignore ...
354 if ($auto != 2) {
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);
360 };
361
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 != '') {
368 $postgroups .= ',';
369 };
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
373 };
374 };
375 };
376 return if $auto == 3; # return if $auto was not reset
377 $testgroup = $postgroups; # set $testgroup for posting a followup
378 };
379
380 $debugmsg .= " --- Posting Check Results ---\n";
381 # ... or if killfile is triggered (if check is not forced) ...
382 if ($auto != 2) {
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
385 foreach (@kill) {
386 ($key,$value) = @{$_};
387 if (defined($header{$key}) and $header{$key}=~/$value/i) {
388 $flag = 1 ;
389 $debugmsg .= " Killfile rule '$key=$value' triggered.\n";
390 };
391 }
392 };
393
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";
398 };
399 if (&hdecode($header{'subject'}) =~ /$trigger_check/io or ($auto==2)) {
400 $docheck = 1;
401 if ($auto==2) {
402 $debugmsg .= " TRIGGER: Check forced via '-c'.\n";
403 $testgroup = $header{'newsgroups'};
404 } else {
405 $debugmsg .= " TRIGGER: Found \"$trigger_check\" in the \"Subject:\"-line, continuing check.\n";
406 };
407 }
408 else {
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");
414 return;
415 } else {
416 $debugmsg .= "; auto-mode activated - no ignore, continuing check.\n";
417 };
418 };
419
420 # put decoded (q/p and base64) headers in %header_decoded
421 foreach $key (keys %header) {
422 $header_decoded{$key} = &hdecode($header{$key});
423 };
424
425 # generate debugmsg for duplicate headers
426 foreach (@duplicate) {
427 $debugmsg .= " $debugdiagmarker Duplicate header line: $_\n"
428 }
429
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'}
437 }
438 if ((defined($newsreader)) and ($newsreader ne '')) {
439 KNOWN: {
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);
451 }
452 }
453 if (!defined($nr)) {
454 $nr = '-';
455 $debugmsg .= " Could not identify newsreader.\n"
456 } else {
457 $debugmsg .= " Newsreader identified: $newsreader [$nr].\n"
458 };
459
460 # * ---> check for 8bit in headers
461 if($wholeheader=~/[\x80-\xFF]/) {
462 $diag{'8bitheader'}=1;
463 $diaglevel=2;
464 $debugmsg .= " $debugdiagmarker 8bit-chars in header.\n";
465 };
466
467 # * ---> check from-header
468 ($frlocpart,$frdompart) = checkfromrp('From');
469
470 # * ---> check reply-to
471 if (defined($header{'reply-to'})) {
472 ($rplocpart,$rpdompart) = checkfromrp('Reply-To');
473 };
474
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 ;
478 $diaglevel ||= 1;
479 $debugmsg .= " $debugdiagmarker \"From:\" = \"Reply-To:\".\n";
480 };
481
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*$)/) {
488 $diag{'nomid'}=1;
489 $diaglevel=2;
490 $debugmsg .= " $debugdiagmarker MID wrong: FQDN is just one word or just numbers.\n";
491 };
492 # invalid chars in domain
493 if($dompart =~ /[^a-z0-9\-.]/) {
494 $diag{'nomid'}=1;
495 $diaglevel=2;
496 $debugmsg .= " $debugdiagmarker MID wrong: FQDN contains invalid characters.\n";
497 };
498 # check for valid TLD
499 if(!defined($domain{$tld})) {
500 $diag{'nomid'}=1;
501 $diaglevel=2;
502 $debugmsg .= " $debugdiagmarker MID wrong: no valid TLD.\n";
503 };
504 # check for <unique%mailaddress@do.main> (USEFOR, used e.g. by MacSOUP)
505 ($f,undef,undef,$i,undef) = &getmailaddress($header_decoded{'from'});
506 $f = quotemeta($f);
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
512 $diag{'nomid'}=1;
513 $diaglevel ||= 1;
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
517 $diag{'nomid'}=1;
518 $diaglevel=2;
519 $debugmsg .= " $debugdiagmarker MID wrong: GMX does not offer usenet service.\n";
520 };
521 if (defined($diag{'nomid'})) {
522 $debugmsg .= " MID was \"$header{'message-id'}\".\n";
523 };
524
525 # * ---> check date
526 ($wtag,$tag,$monat,$jahr,$zeit) = (split / +/, $header{'date'});
527 if (!($wtag=~/\w{3},/)) {
528 $zeit = $jahr;
529 $jahr = $monat;
530 $monat = $tag;
531 $tag = $wtag;
532 };
533 if ($jahr < 1970) {
534 $diag{'date'}=1;
535 $diaglevel=2;
536 $debugmsg .= " $debugdiagmarker \"Date:\" is incorrect: year < 1970.\n";
537 $debugmsg .= " \"Date:\" was: \"$header{'date'}\".\n";
538 };
539
540 # * ---> check for html
541 if(defined($header{'content-type'})&&$header{'content-type'}=~/html/i) {
542 $diag{'html'}=1;
543 $diaglevel=1;
544 $debugmsg .= " $debugdiagmarker HTML detected (no multipart/alternative!).\n";
545 };
546
547 # * ---> check for multiparts
548 if(defined($header{'content-type'}) and ($header{'content-type'}=~/multipart/)) {
549 $diag{'multipart'}=1;
550 $diaglevel ||= 1;
551 $debugmsg .= " $debugdiagmarker MIME-multipart identified.\n";
552 $debugmsg .= " Cannot check body of that posting - do not understand multipart yet.\n";
553 };
554
555 # apply checks to body only if there _is_ a body
556 if (defined($wholebody)) {
557 if(defined($header{'content-transfer-encoding'})) {
558
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;
570 };
571
572 # * ---> check for base64 (body)
573 if($header{'content-transfer-encoding'}=~/base64/i){
574 $diag{'base64'}=1;
575 $diaglevel=1;
576 $debugmsg .= " $debugdiagmarker Content-transfer-encoding: Base64.\n";
577 $debugmsg .= " Will decode that body now.\n";
578 $wholebody = decode_base64($wholebody); # do Base64-decoding
579 };
580 }
581
582 # split $wholebody into single lines
583 @body=split("\n",$wholebody);
584
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");
591 return;
592 }
593
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;
603 $diaglevel=2;
604 $debugmsg .= " $debugdiagmarker Header \"Content-Type:\" does not define charset.\n";
605 };
606 if($header{'content-type'}=~/us-ascii/) {
607 $diag{'nocharset'}=1;
608 $diaglevel=2;
609 $debugmsg .= " $debugdiagmarker Charset is \"US-ASCII\".\n";
610 };
611 }else{
612 $diag{'nocharset'}=1;
613 $diaglevel=2;
614 $debugmsg .= " $debugdiagmarker No charset defined.\n";
615 }
616 if(!defined($header{'content-transfer-encoding'})) {
617 $diag{'nocontenttransferenc'}=1;
618 $diaglevel=2;
619 $debugmsg .= " $debugdiagmarker No content-transfer-encoding defined.\n";
620 };
621 }
622 }
623
624 # * ---> check for vcards
625 if($wholebody=~/(^begin:vcard\s*$)(.|[\n])+(^end:vcard\s*$)/im) {
626 $diag{'vcard'}=1;
627 $diaglevel ||= 1;
628 $debugmsg .= " $debugdiagmarker V-Card identified.\n";
629 };
630
631 $sigstart = $#body;
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)
636 };
637 if($body[$i]=~/^(- )?--[^-]?\s*$/){
638 $sigstart = $i;
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";
645 } else {
646 $sigokay ||= $i+1;
647 $debugmsg .= " Sig-delimiter is correct or not checked.";
648 if ($diag{'sigdelimiter'} == 1) {
649 delete $diag{'sigdelimiter'};
650 $debugmsg .= " - Reset error-message.\n";
651 } else {
652 $debugmsg .= "\n"; };
653 };
654 if($sigokay > 0) {
655 $f = $sigokay-1;
656 } else {
657 $f = $i;
658 };
659 if ($f+4<$#body) {
660 $diag{'longsig'}=1;
661 $diaglevel ||= 1;
662 $debugmsg .= " $debugdiagmarker Sig is too long [starting line ".($f+2)." - ending line ".($#body+1)."].\n";
663 };
664 }
665 }
666 if ($diag{'sigdelimiter'} == 1) {$diaglevel ||= 1;};
667
668 # lines to long
669 LINECHECK:
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;
674 $diaglevel ||= 1;
675 $debugmsg .= " $debugdiagmarker Line " . ($i+1) . " too long and not quoted.\n";
676 $debugmsg .= " Offending line: " . $body[$i] . "\n";
677 };
678 }
679
680 if ($sigstart < $#body) {
681 SIGCHECK:
682 for ($i=$sigstart; $i<=$#body; $i++) {
683 last SIGCHECK if(!defined($body[$i]));
684 if($body[$i]=~/^.{81,}$/) {
685 $diag{'longlinesig'}=1;
686 $diaglevel ||= 1;
687 $debugmsg .= " $debugdiagmarker Line " . ($i-$sigstart) . " of signature too long.\n";
688 $debugmsg .= " Offending line: " . $body[$i] . "\n";
689 }
690 }
691 }
692 } else {
693 $debugmsg .= " Message does not contain body.\n"
694 };
695
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})) {
699 delete $diag{$i};
700 $debugmsg .= " ! Configuration: Text for [$i] missing - problem was found, but won't be reported.\n";
701 }
702 }
703
704 # increase diaglevel if pedantic is on
705 if ($pedantic) { $diaglevel += 1; };
706
707 $debugmsg .= " --- End of Check Results ---\n\n";
708
709 # if subject == 'check' or auto == 1 and $diaglevel > 1:
710 # post followup
711 if ($docheck or ($auto && ($diaglevel > 1))) {
712 op(2,"Got one! ---> $header{'message-id'}\n");
713 op(2,"Generating followup, writing to $testgroup ...");
714 # generate followup
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"
721 } else {
722 push @article, "References: $header{'message-id'}\n"
723 }
724 ($wtag,$monat,$tag,$zeit,$jahr) = (split / +/, (scalar gmtime));
725 push @article, "Date: $wtag, $tag $monat $jahr $zeit GMT\n";
726 $f = "Subject: ";
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";
733 }
734 if ($auto==2) {
735 push @article, "X-Comment: Check enforced by operator using '$0 -c'.\n";
736 }
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";
740 push @article, "\n";
741 if ($auto==2) {
742 push @article, $config{'header-forced'}
743 } elsif ($docheck) {
744 push @article, $config{'header'}
745 } elsif ($auto) {
746 push @article, $config{'header-auto'}
747 } else {
748 push @article, "\nCHECKBOT INTERNAL ERROR!\n"
749 }
750 push @article, "\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]));
755 push @article, "\n";
756
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";
763 };
764 push @article, "\n"; #-# 1.2.01k
765 };
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
771 };
772 if (defined($config{"$i-$nr"}) && $diag{$i}==1) {
773 push @article, ev("$i-$nr"), "\n"; # Variablen expandieren
774 };
775 };
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));
779 };
780 if (defined($config{'violation'}) && $diaglevel > 1) { #-# 1.2.01k
781 push @article, "$config{'violation'}\n";
782 };
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
787 };
788 if (defined($header{'x-trace'}) and ($header{'x-trace'}=~/^fu-berlin.de/) and defined($config{'newscis'})) {
789 push @article, "$config{'newscis'}\n";
790 };
791 }else{
792 push @article, $config{'allok'},"\n";
793 }
794
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";
799 push @article, $f;
800 };
801
802 push @article, $config{'footer'};
803
804 if ($feedmode) { #-# 1.2.01k ---->
805 # open server for posting
806 if ($postingserver ne '') {
807 $postserver = &connectserver($postingserver,$postingport,$posts_user,$posts_pass)
808 } else {
809 $postserver = &connectserver($server,$port,$s_user,$s_pass);
810 };
811 $f = \$postserver;
812 } else { #-# 1.2.01k <-----
813 if ($postingserver ne '') {
814 $f = \$postserver;
815 $i = "$postingserver";
816 if ($postingport ne '') {
817 $i .= "(Port $postingport)";
818 }
819 } else {
820 $f = \$readserver;
821 $i="$server";
822 if ($port ne '') {
823 $i .= " (Port $port)";
824 }
825 }
826 };
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");
836 } else {
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);
840 };
841 };
842 } else {
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);
846 };
847 if ($feedmode) { #-# 1.2.01k
848 $postserver->quit;
849 };
850 op(14,"\n$header{'message-id'}:\n$debugmsg\n\n");
851 } else {
852 op(15,"$header{'message-id'}:\n$debugmsg\n");
853 }
854}
855
856################################################################
857# Subroutines: get_mail_address
858# encode_header / hdecode / dodecode
859# evaluate variables
860# generic output routinte (instead of 'print')
861# connect to server
862
863sub getmailaddress {
864 my($raw)=shift;
865 my($tmp,$address,$name,$lp,$dp,$type);
866 if($raw=~/^<?($r_address)>?$/) {
867 $type = 1;
868 $address = $1;
869 $name = '';
870 } elsif($raw=~/^($r_address)\s+\($r_paren_phrase\)\s*$/) {
871 $type = 2;
872 $address = $1;
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*$/) {
876 $type = 3;
877 $name = $1;
878 ($address = $raw) =~ s/.*<($r_address)>\s*$/$1/;
879 };
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) {
884 $tmp = lc($tmp);
885 };
886 return $address, $name, $lp, $dp, $type;
887}
888
889sub checkfromrp {
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});
894 my $tld;
895 ($tld = $dompart) =~ s/.*\.([^.]+)$/$1/; # isolate TLD
896 $tld = lc($tld);
897 if ($hname eq 'from') {
898 if($type==1) {
899 $debugmsg .= " \"From:\"-header is type 1 [address\@do.main].\n";
900 }elsif($type==2) {
901 $debugmsg .= " \"From:\"-header is type 2 [address\@do.main (full name)].\n";
902 }elsif($type==3) {
903 $debugmsg .= " \"From:\"-header is type 3 [full name <address\@do.main>].\n";
904 }else{
905 $diag{'from'}=1;
906 $diaglevel=2;
907 $debugmsg .= " $debugdiagmarker \"From:\"-syntax is incorrect.\n";
908 };
909 } else {
910 if($type==0) {
911 $diag{'reply-to'}=1;
912 $diaglevel=2;
913 $debugmsg .= " $debugdiagmarker \"Reply-To:\" is incorrect.\n";
914 };
915 }
916 $f = lc($dompart);
917 if($f =~ /[^a-z0-9\-.]/) {
918 $diag{$hname}=1;
919 $diaglevel=2;
920 $debugmsg .= " $debugdiagmarker \"$headername:\" is incorrect: invalid chars in domain.\n";
921 };
922 if($type!=0) {
923 # domain
924 if(!defined($domain{$tld})) {
925 $diag{"$hname".'-domain'}=1;
926 $diaglevel=2;
927 $debugmsg .= " $debugdiagmarker \"$headername:\" is incorrect: no valid TLD.\n";
928 # MX-/A-lookup
929 } else {
930 if ($online) {
931 $res = Net::DNS::Resolver -> new();
932 $res->usevc(1);
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;
945 $diaglevel=2;
946 };
947 };
948 };
949 };
950 # no name, just address?
951 if ($hname eq 'from') {
952 if($name !~ /[a-z][^.]\S*\s+\S*([a-z][^.]\S*)+/i) {
953 $diag{'noname'}=1;
954 $diaglevel ||= 1;
955 $debugmsg .= " $debugdiagmarker \"From:\" does not contain full name.\"\n";
956 };
957 };
958 # check for role accounts
959 ROLES: foreach $f (@roles) {
960 if ($f eq lc($locpart)) {
961 $diag{"$hname".'-roles'}=1;
962 $diaglevel ||= 1;
963 $debugmsg .= " $debugdiagmarker \"$headername:\" contains role account.\"\n";
964 last ROLES;
965 };
966 };
967 };
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";
972 };
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";
977 };
978 };
979 return ($locpart,$dompart);
980}
981
982sub encode_header {
983 my $header=shift;
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).'?=';
989 }
990 $encoded_header .= "$word$space";
991 }
992 $encoded_header =~ s/\?=(\s+)=\?iso-8859-1\?Q\?/$1/g;
993 return $encoded_header;
994}
995
996
997sub hdecode {
998 my $header=shift;
999 if ($header=~/=\?.*\?(.)\?(.*)\?=/) {
1000 $header=~s/=\?.*\?(.)\?(.*)\?=/&dodecode($1,$2)/ge;
1001 };
1002 $header=~s/\n\t//; # unfold headers
1003 return $header;
1004}
1005
1006
1007sub dodecode {
1008 # decode RFC 1522 headers
1009 my $enc=shift;
1010 my $etext=shift;
1011
1012 if($enc=~/^q$/i){
1013 $etext=decode_qp($etext);
1014 $etext=~s/_/' '/ge;
1015 }elsif($enc=~/^b$/i){
1016 $etext=decode_base64($etext);
1017 }else{$etext=''}
1018 return $etext;
1019}
1020
1021
1022sub op {
1023# (debug) output
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) = @_;
1031 if ($level >= 10) {
1032 if ($logging) { print LOG $text; };
1033 $level -= 10;
1034 };
1035 $handle ||= 'STDOUT';
1036 if ($debuglevel >= $level and not $feedmode) {
1037 print $handle $text;
1038 };
1039}
1040
1041
1042
1043sub connectserver {
1044 my($server,$port,$s_user,$s_pass) = @_;
1045
1046 # connect to server
1047 op(0,"Connecting to news server ...");
1048 my $c = new News::NNTPClient($server,$port);
1049
1050 if (!($c->code)) {
1051 op(0,"\nCan't connect to server. Aborting.\n");
1052 die "\nCan't connect to server. Aborting.\n";
1053 } else {
1054 op(0," done.\n");
1055 }
1056
1057 $c->postok() or op(0,"Server does not allow posting?!\n");
1058
1059 op(3,"$serverresponse".$c->code.' '.$c->message);
1060
1061 # switch off error messages from News::NNTPClient
1062 $c->debug(0);
1063
1064 # mode reader
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";
1069 } else {
1070 op(1," done.\n");
1071 op(3,"$serverresponse".$c->code.' '.$c->message);
1072 };
1073
1074 # authorize, if needed
1075 if ($s_user ne '') {
1076 op(1,"Authentification ...");
1077 if ($c->authinfo($s_user,$s_pass)) {
1078 op(1," done.\n");
1079 } else {
1080 op(0,"\nAuthentification failure. Aborting.\n");
1081 die "\nAuthentification failure. Aborting.\n";
1082 }
1083 op(3,"$serverresponse", $c->code, ' ', $c->message);
1084 };
1085
1086 op(0,"\n");
1087 $c;
1088}
1089
1090
1091################################################################
1092# Subroutines for reading / writing files
1093# - read rc
1094# - read/write ini
1095# - read domains
1096
1097sub readrcfile {
1098 my($a,$i);
1099 open(RC,'<'.$pathtoini.$rcname.'.rc')||die "Could not open $pathtoini"."$rcname.rc for reading: $!";
1100 $a='';
1101 until(eof(RC)){
1102 $i=<RC>;
1103 next if(substr($i,0,1) eq ';');
1104 if($i=~/^\[.*\]$/){ $a=substr($i,1,-2);next; }
1105 $config{$a}.=$i;
1106 }
1107 close(RC);
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");
1113 exit(1);
1114 }
1115 }
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");
1124 }
1125 }
1126}
1127
1128
1129sub readini {
1130 my($a,$b,$c);
1131 open(INI,'<'.$pathtoini.$ininame.'.ini')||die "Could not open $pathtoini"."$ininame.ini for reading: $!";
1132 until(eof(INI)) {
1133 $c=<INI>;
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') {
1141 chomp($s_user=$b);
1142 } elsif ($a eq 'reader_pass') {
1143 chomp($s_pass=$b);
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') {
1155 chomp($rcname=$b);
1156 } elsif ($a eq 'killfile') {
1157 chomp($killname=$b);
1158 }
1159 } elsif ($c =~/checkgroups:/) {
1160 until(eof(INI)){
1161 chomp(($a,$b,$c)=split(/ /,<INI>));
1162 @testgroups = (@testgroups, $a) unless ($a!~/^\w+(\.\w+)+/);
1163 if ($b eq 'y') {
1164 $auto{$a} = 1;
1165 }else{
1166 $auto{$a} = 0;
1167 };
1168 $watermark{$a} = $c;
1169 if (!defined($watermark{$a})) {$watermark{$a} = 0};
1170 }
1171 }
1172 }
1173 close(INI);
1174 if($server eq '') {
1175 op(0,"You have to define a reading server in $ininame.ini\n");
1176 exit(1);
1177 }
1178 if($trigger_check eq '') {
1179 $trigger_check='check';
1180 }
1181 if($trigger_ignore eq '') {
1182 $trigger_ignore='(ignore)|(no[ ]*repl(y|(ies)))|(nocheck)';
1183 }
1184 if($rcname eq '') {
1185 $rcname=$ininame;
1186 } elsif ($rcname=~/\.rc$/) {
1187 $rcname=~s/(.*?)\.rc$/$1/;
1188 }
1189 if($killname eq '') {
1190 $killname=$ininame;
1191 } elsif ($killname=~/\.kill$/) {
1192 $killname=~s/(.*?)\.kill$/$1/;
1193 }
1194 if(scalar(@testgroups) == 0) {
1195 op(0,"You have to define at least one testgroup in $ininame.ini\n");
1196 exit(1);
1197 }
1198}
1199
1200
1201sub writeini {
1202 my($r,$tmp,$point);
1203 open(INI,'<'.$pathtoini.$ininame.'.ini')||die "Could not open $pathtoini"."$ininame.ini for reading: $!";
1204 until(eof(INI)) {
1205 $r = <INI>;
1206 $tmp .= $r;
1207 if ($r =~/checkgroups:/) {
1208 last;
1209 }
1210 }
1211 close (INI);
1212 open(INI,'>'.$pathtoini.$ininame.'.ini')||die "Could not open $pathtoini"."$ininame.ini for writing: $!";
1213 print INI $tmp;
1214 foreach $testgroup (@testgroups) {
1215 print INI "$testgroup ";
1216 if ($auto{$testgroup} == 0) {
1217 print INI 'n '
1218 }else{
1219 print INI 'y '
1220 };
1221 print INI "$watermark{$testgroup}\n";
1222 }
1223 close(INI);
1224}
1225
1226
1227sub readdomains {
1228 my ($i,@domains);
1229 open(DOM,'<'.$pathtoini.'domains')||die "Could not open \"$pathtoini"."domains\" for reading: $!";
1230 chomp(@domains = split(/ /,<DOM>));
1231 close(DOM);
1232 $i = 0;
1233 until(!defined(@domains[$i])) {
1234 $domain{$domains[$i]} = 'valid';
1235 $i++;
1236 };
1237}
1238
1239__END__
Checkbot
This page took 0.236043 seconds and 4 git commands to generate.