artchk.pl

   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
  47 use News::NNTPClient;
  48 use MIME::QuotedPrint;
  49 use MIME::Base64;
  50 use Net::DNS;
  51 use 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
  82 while (@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
 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 !~ /.*(\/|\\)$/) {
 119  $pathtoini .= '/';
 120 }
 121 if (!defined($checkpost) or ($checkpost!~/<\S+\@\S+>/)) {$checkpost = 'no'};
 122 if (!defined($logfile)) {$logfile = "$ininame"};
 123
 124 # open logfile
 125 if ($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
 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");
 136
 137 # read .rc-file / .ini-file / domains / killfile
 138 &readini;
 139 &readrcfile;
 140 &readdomains;
 141 if (-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
 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")};
 166 } else {
 167  op(11, "Posting to check: $checkpost\n");
 168 };
 169 op(1, "\n\n");
 170 op(1, "---------- Starting connection procedure ----------\n");
 171
 172 if ($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
 247 if ($logging) {
 248  op(15,"$0 $version terminated successfully on ".scalar(gmtime)." GMT.\n");
 249  close LOG;
 250 };
 251 op(0,"Program terminated on ".scalar(gmtime)." GMT.\n\n");
 252 op(0,"Thank you for using.\n");
 253 exit(0);
 254
 255 ################################################################
 256 # Main subroutines: get article / feed article / check article
 257
 258 sub 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
 292 sub 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
 306 sub 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
 863 sub 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
 889 sub 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
 982 sub 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
 997 sub 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
1007 sub 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
1022 sub 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
1043 sub 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
1097 sub 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
1129 sub 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
1201 sub 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
1227 sub 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__