UVreadmail.pm

   1 # UVreadmail: functions for reading and processing mailfiles
   2 # Used by uvvote.pl, uvcfv.pl, uvbounce.pl
   3
   4 package UVreadmail;
   5
   6 use strict;
   7 use UVconfig;
   8 use UVmessage;
   9 use MIME::QuotedPrint;
  10 use MIME::Base64;
  11 use MIME::Parser;
  12 use POSIX qw(strftime);
  13
  14 use vars qw($VERSION);
  15
  16 # Module version
  17 $VERSION = "0.11";
  18
  19 sub process {
  20
  21   # $filename: file containing bounces or (if POP3 is enabled) where
  22   #            mails should be saved
  23   # $callsub:  reference to a sub which should be called for each mail
  24   # $caller:   0 = uvvote.pl, 1 = uvcfv.pl, 2 = uvbounce.pl
  25   #            3 = uvbounce.pl but POP3 disabled (overrides $config{pop3}
  26   #
  27
  28   my ($filename, $callsub, $caller) = @_;
  29   my ($voter_addr, $voter_name, $body);
  30   my $count = 0;
  31   my ($pop3server, $pop3user, $pop3pass, $pop3delete, $pop3uidlcache);
  32   my @mails = ();
  33   $caller ||= 0;
  34
  35   if ($config{pop3} && $caller<3) {
  36
  37     if ($caller == 1) {
  38       # Ballot request (personal = 1 set in usevote.cfg) from uvcfv.pl
  39       $pop3server = $config{pop3server_req} . ':' . $config{pop3port_req};
  40       $pop3user = $config{pop3user_req};
  41       $pop3pass = $config{pop3pass_req};
  42       $pop3delete = $config{pop3delete_req};
  43       $pop3uidlcache = $config{pop3uidlcache_req};
  44     } elsif ($caller == 2) {
  45       # called from uvbounce.pl
  46       $pop3server = $config{pop3server_bounce} . ':' . $config{pop3port_bounce};
  47       $pop3user = $config{pop3user_bounce};
  48       $pop3pass = $config{pop3pass_bounce};
  49       $pop3delete = $config{pop3delete_bounce};
  50       $pop3uidlcache = $config{pop3uidlcache_bounce};
  51     } else {
  52       $pop3server = $config{pop3server} . ':' . $config{pop3port};
  53       $pop3user = $config{pop3user};
  54       $pop3pass = $config{pop3pass};
  55       $pop3delete = $config{pop3delete};
  56       $pop3uidlcache = $config{pop3uidlcache};
  57     }
  58
  59     # read list of seen mails (UIDLs)
  60     my %uidls = ();  # hash for quick searching
  61     my @uidls = ();  # array to preserve order
  62     my $cacheexist = 1;
  63     open (UIDLCACHE, "<$pop3uidlcache") or $cacheexist = 0;
  64     if ($cacheexist) {
  65       while (my $uidl = <UIDLCACHE>) {
  66         chomp ($uidl);
  67         $uidls{$uidl} = 1;
  68         push (@uidls, $uidl);
  69       }
  70       close (UIDLCACHE);
  71     }
  72
  73     print UVmessage::get("READMAIL_STATUS"), "\n" unless ($caller == 2);
  74
  75     # open POP3 connection and get new mails
  76     use Net::POP3;
  77     my $pop = Net::POP3->new($pop3server)
  78       or die UVmessage::get("READMAIL_NOCONNECTION") . "\n\n";
  79
  80     my $mailcount = $pop->login($pop3user, $pop3pass);
  81
  82     die UVmessage::get("READMAIL_NOLOGIN") . "\n\n" unless ($mailcount);
  83
  84     for (my $n=1; $n<=$mailcount; $n++) {
  85       my $uidl = $pop->uidl($n);
  86       if ($uidl) {
  87         next if ($uidls{$uidl});
  88         $uidls{$uidl} = 1;
  89         push (@uidls, $uidl);
  90       }
  91       my $mailref = $pop->get($n)
  92          or print STDERR UVmessage::get("READMAIL_GET_PROBLEM", (NR => $n)) . "\n";
  93       my $mail = join ('', @$mailref);
  94       my $fromline = 'From ';
  95       if ($mail =~ /From: .*?<(.+?)>/) {
  96         $fromline .= $1;
  97       } elsif ($mail =~ /From:\s+?(\S+?\@\S+?)\s/) {
  98         $fromline .= $1;
  99       } else {
 100         $fromline .= 'foo@bar.invalid';
 101       }
 102       $fromline .= ' ' . strftime ('%a %b %d %H:%M:%S %Y', localtime) . "\n";
 103       push (@mails, $fromline . $mail);
 104       if ($pop3delete) {
 105         $pop->delete($n)
 106           or print STDERR UVmessage::get("READMAIL_DEL_PROBLEM", (NR => $n)) . "\n";
 107       }
 108     }
 109
 110     # save UIDLs
 111     my $uidlerr = 0;
 112     open (UIDLCACHE, ">$pop3uidlcache") or $uidlerr = 1;
 113     if ($uidlerr) {
 114       print STDERR UVmessage::get("READMAIL_UIDL_PROBLEM") . "\n";
 115       print STDERR UVmessage::get("READMAIL_UIDL_PROBLEM2") . "\n";
 116     } else {
 117       print UIDLCACHE join("\n", @uidls);
 118       close (UIDLCACHE) or print STDERR UVmessage::get("READMAIL_UIDL_CLOSE") . "\n";
 119     }
 120
 121     # make archive of all mails
 122     my $fileproblem = 0;
 123     open (VOTES, ">$filename") or $fileproblem = 1;
 124     if ($fileproblem) {
 125       print STDERR UVmessage::get("READMAIL_ARCHIVE_PROBLEM",
 126                    (FILE => $filename)) . "\n";
 127     } else {
 128       print VOTES join ("\n", @mails);
 129       close (VOTES)
 130         or print STDERR UVmessage::get("READMAIL_ARCHIVE_CLOSE",
 131                         (FILE => $filename)) . "\n";
 132     }
 133
 134     $pop->quit();
 135
 136   } else {
 137     # open mail file
 138     open(VOTES, "<$filename")
 139         or die UVmessage::get("READMAIL_NOMAILFILE", (FILE => $filename)) . "\n\n";
 140
 141     # read all mails
 142     my $i = 0;
 143     while (<VOTES>) {
 144       if (/$config{mailstart}/) {
 145         $i++;
 146       }
 147       $mails[$i] = ($mails[$i] || "") . $_;
 148     }
 149
 150     # close mail file
 151     close(VOTES);
 152   }
 153
 154   foreach my $mail (@mails) {
 155     next unless $mail;
 156
 157     # split mail into array and remove first line (from line)
 158     my @mail = split(/\n/, $mail);
 159     shift (@mail) if ($mail[0] =~ /^From /);
 160
 161     # generate MIME-Parser object for the mail
 162     my $parser = new MIME::Parser;
 163     # headers are to be decoded
 164     $parser->decode_headers(1);
 165     # don't write into file
 166     $parser->output_to_core(1);
 167
 168     # read mail
 169     my $entity = $parser->parse_data(join("\n", @mail));
 170     my $head = $entity->head;
 171
 172     # extract address and name
 173     my $from = $head->get('From') || '';
 174
 175     if ($from =~ /\s*([^<]\S+\@\S+[^>]) \((.+)\)/) {
 176       ($voter_addr, $voter_name) = ($1, $2);
 177     } elsif ($from =~ /\s*\"?([^\"]+)\"?\s*<(\S+\@\S+)>/) {
 178       ($voter_name, $voter_addr) = ($1, $2);
 179       $voter_name =~ s/\s+$//;  # kill spaces at the end
 180     } elsif ($from =~ /\s*<?(\S+\@[^\s>]+)>?[^\(\)]*/) {
 181       ($voter_addr, $voter_name) = ($1, '');
 182     } else {
 183       # initialize with empty value
 184       $voter_addr = '';
 185       $voter_name = '';
 186     }
 187
 188     # look at reply-to?
 189     if ($config{replyto}) {
 190
 191       my $replyto = Mail::Field->new('Reply-To', $head->get('Reply-To'));
 192
 193       # Address in Reply-To?
 194       ($voter_addr) = $replyto->addresses() if ($replyto->addresses());
 195
 196       # Name in reply-to?
 197       if ($replyto->names()) {
 198          my ($nametmp) = $replyto->names();
 199          $voter_name = $nametmp unless ($nametmp =~ /^\s*$/);
 200       }
 201
 202     }
 203
 204     # decode body
 205     my $encoding = $head->get('Content-Transfer-Encoding') || '';
 206     if ($encoding =~ /quoted-printable/i) {
 207       $body = decode_qp($entity->stringify_body);
 208     } elsif ($encoding =~ /base64/i) {
 209       $body = decode_base64($entity->stringify_body);
 210     } else {
 211       $body = $entity->stringify_body;
 212     }
 213
 214     my $h_date = $head->get('Date') || '';
 215     chomp $h_date;
 216
 217     # call referred sub and increase counter
 218     &$callsub($voter_addr, $voter_name, $h_date, $entity, \$body);
 219     $count++;
 220   }
 221
 222   return $count;
 223 }
 224
 225 1;