Perl-Skript sichert Chat-Protokolle auf IMAP-Server

001 #!/usr/bin/perl -w
002 use strict;
003 use Gaim::Log::Parser 0.04;
004 use Gaim::Log::Finder;
005 use Sysadm::Install 0.23 qw(:all);
006 use Lingua::StopWords;
007 use Text::Language::Guess;
008 use Log::Log4perl qw(:easy);
009 use Text::Wrap qw(fill $columns);
010 use URI::Find;
011 use IMAP::Client;
012 use DateTime::Format::Mail;
013 
014 my $mailbox = "im_mailbox";
015 my $tzone  = "America/Los_Angeles";
016 my $min_age = 3600;
017 my $sleep  = 3600;
018 
019 my %im_stopwords = map { $_ => 1 } qw(
020 maybe thanks thx doesn hey put already
021 said say would can could haha hehe see
022 well think like heh now many lol doh );
023 
024 Log::Log4perl->easy_init({
025  level => $DEBUG, category => "main",
026  file => ">>$ENV{HOME}/.gaim2imap.log"
027 });
028 
029 my $PW = password_read("password: ");
030 
031 my $pid = fork();
032 die "fork failed" if ! defined $pid;
033 exit 0 if $pid;
034 
035 dbmopen my %SEEN,
036     "$ENV{HOME}/.gaim/.seen", 0644 or
037    LOGDIE "Cannot open dbm file ($!)";
038 
039 $SIG{TERM} = sub { INFO "Exiting";
040   dbmclose %SEEN;
041   exit 0;
042 };
043 
044 while(1) {
045   update();
046   INFO "Sleeping $sleep secs";
047   sleep $sleep;
048 }
049 
050 ###########################################
051 sub update {
052 ###########################################
053  DEBUG "Connecting to IMAP server";
054 
055  my $imap = new IMAP::Client();
056  $imap->onfail('ABORT');
057  $imap->connect(PeerAddr => 'localhost',
058    ConnectMethod => 'PLAIN');
059 
060  my $u = getpwuid $>;
061  $imap->authenticate($u, $PW);
062 
063  my $finder = Gaim::Log::Finder->new(
064   callback => sub {
065    my($self, $file, $protocol,
066      $from, $to) = @_;
067 
068    return 1 if $from eq $to;
069 
070    my $mtime = (stat $file)[9];
071    my $age = time() - $mtime;
072 
073    return 1 if $SEEN{$file} and
074          $SEEN{$file} == $mtime;
075 
076    if($age < $min_age) {
077      INFO "$file: Too recent ($age)";
078      return 1;
079    }
080 
081    $SEEN{$file} = $mtime;
082    INFO "Processing log file: $file";
083    my($subject, $formatted, $epoch) =
084           chat_process($file);
085 
086    imap_add($imap, $mailbox, $epoch,
087         "$to@gaim", "", $subject,
088         $formatted);
089  });
090 
091  $finder->find();
092 }
093 
094 ###########################################
095 sub chat_process {
096 ###########################################
097  my($file) = @_;
098 
099  my $parser = Gaim::Log::Parser->new(
100   file => $file,
101  );
102    # Search+delete URL processor
103  my $urifind = URI::Find->new(sub {""});
104 
105  my $text   = "";
106  my $formatted = "";
107  my $urifound;
108  $Text::Wrap::columns = 70;
109 
110  while(my $m = $parser->next_message()) {
111   my $content = $m->content();
112   $content =~ s/n+/ /g;
113   $formatted .= fill("", " ",
114    nice_time($m->date()) . " " .
115    $m->from() . ": " . $content) . "nn";
116 
117   $urifound =
118     $urifind->find($content);
119   $text .= " " . $content;
120  }
121 
122  my $guesser = Text::Language::Guess->
123       new(languages => ['en', 'de']);
124 
125  my $lang =
126   $guesser->language_guess_string($text);
127 
128  $lang = 'en' unless $lang;
129  DEBUG "Guessed language: $langn";
130 
131  my $stopwords =
132   Lingua::StopWords::getStopWords($lang);
133 
134  my %words;
135 
136  while($text =~ /b(w+)b/g) {
137   my $word = lc($1);
138   next if $stopwords->{$word};
139   next if $word =~ /^d+$/;
140   next if length($word) <= 2;
141   next if exists $im_stopwords{$word};
142   $words{$word}++;
143   $words{$word} += 3 if length $word > 6;
144  }
145 
146  my @weighted_words = sort {
147   $words{$b} <=> $words{$a}
148  } keys %words;
149 
150  my $subj = ($urifound ? '*L*' : "");
151  my $char = "";
152 
153  while(@weighted_words and length($subj) +
154    length($char .
155            $weighted_words[0]) <= 70) {
156   $subj .= $char . shift @weighted_words;
157   $char = ", ";
158  }
159 
160  return($subj, $formatted,
161      $parser->{dt}->epoch());
162 }
163 
164 ###########################################
165 sub imap_add {
166 ###########################################
167  my($imap, $mailbox, $date,
168    $from, $to, $subject, $text) = @_;
169 
170  $date =
171   DateTime::Format::Mail->format_datetime(
172    DateTime->from_epoch(
173      epoch => $date,
174      time_zone => $tzone));
175 
176  my $message = "Date: $daten" .
177   "From: $fromn" .
178   "To: $ton" .
179   "Subject: $subjectnn$text";
180 
181  my $fl = $imap->buildflaglist();
182  $imap->append($mailbox, $message, $fl);
183 }