## ==================================================================================== ##
## reklama2.pl - Homeric's eGroups ad remover, version 2.2 ##
## ##
## ОПИСАНИЕ ##
## ##
## Этот скрипт работает с UNIX-ящиками в указанной директории и удаляет из почты: ##
## - рекламу eGroups, ##
## - подписи некоторых листов рассылки, ##
## - заголовки Received, Delivered-To, Return-Path, X-eGroups-*, ##
## - префиксы ответа в сабжах, например Re:, Re[2]:, Fwd:, ##
## - маркеры конференций в сабжах, например [st], [ft], [pt], [ctalk]. ##
## - пробелы из строк состоящих из одних пробелов ##
## - лишние переводы строк в конце каждого письма ##
## ##
## ЧТО НОВОГО ##
## ##
## Версия 2.2 ##
## ##
## [+] добавлены новые регекспы, по просьбам трудящихся читателей конференций ;-) ##
## [+] более агрессивное удаление рекламы, например процитированной рекламы ##
## [-] базы с случайными 0d 0a (что не совсем UNIX-mail) не читались правильно. ##
## ##
## Версия 2.0 ##
## ##
## [+] заголовки и тело письма обрабатываются отдельно, ##
## [-] отныне не удаляются части тела письма которые похожи на заголовки (например ##
## обсуждение заголовков Received в конференции BatTalk). ##
## [+] В модуль с регекспами можно поместить разные регекспы для заголовков и тела ##
## письма. ##
## [*] программа лучше разделена на модули, которые теперь делают только конкретные ##
## задачи ##
## [+] чтение файлов происходит не полностью, а построчно. ##
## ##
## ОГРАНИЧЕНИЯ ##
## ##
## Фильтрация рекламы, подписей и тем происходит только в случае если текст или тема ##
## письма не закодированы в base64 или quoted-printable. Заголовки писем удаляются ##
## в любом случае. ##
## ##
## Скрипт ищет только в корневой директории, в поддиректориях он файлы не обрабатывает. ##
## ##
## DISCLAIMER ##
## ##
## Внимание: автор скрипта не несёт ответственность за потерю данных и другой ущерб ##
## от использования данного скрипта. Убедительная просьба не писать отфильтрованные ##
## файлы поверх исходных, делайте разными либо расширения либо директории. ##
## ##
## РАСПРОСТРАНЕНИЕ ##
## ##
## Распространение данного скрипта приветствуется. При распространении необходимо ##
## сохранять заметку в следующем абзаце. ##
## ##
## (x) Evgeny AKA Homeric (homeric1245@bigfoot.com). This script is in public domain. ##
## Please keep this notice. ##
## ==================================================================================== ##
use strict;
use warnings;
sub processFile ($$);
sub processDirectory ($$$$);
sub processMessage($);
sub statsForThisRun();
################################################################################
### НАСТРОЙКИ
## ВНИМАНИЕ: указанные директории должны существовать!
## директория, в которой лежат исходные UNIX-ящики
my $sourceDir = 'D:/mail/egroups';
#my $sourceDir = 'D:/backups/egroups/egroups_text';
#my $sourceDir = 'D:/backups/eg2';
## расширения у исходных UNIX-ящиков
my $sourceExt='txt';
## директория, в которую нужно положить отфильтрованные от рекламы UNIX-ящики
my $destDir = $sourceDir;
## расширения, которое будет у отфильтрованных файлов
my $destExt='txt';
## файл для журнала и статистики (если файла нет, то он будет создан,
## директория должна существовать)
my $logFileName ='D:/mail/egroups/~reklama.log';
### настроили ;-)
################################################################################
my $global_totalBytesRead = 0; ## глобальные переменные для
my $global_totalReplacements = 0; ## подсчёта статистики по прочитанным
my $global_totalBytesWritten = 0; ## и записанным байтам,
my $global_totalBytesSaved = 0; ## а также по количеству замен
## печатаем название программы на экран
print "== Homeric's eGroups ad remover, version 2.2 ==\n\n";
if (open (LOGFILE, ">>$logFileName")) ## если можем открыть логфайл, то
{ ## печатаем название в файл
print LOGFILE "== Homeric's eGroups ad remover, version 2.2 ==\n\n";
## и обрабатываем всю директорию
processDirectory ($sourceDir, $sourceExt, $destDir, $destExt);
print LOGFILE statsForThisRun; ## пишем статистику в лог
close (LOGFILE); ## и закрываем лог. Аминь.
print statsForThisRun; ## печатаем статистику на экран.
}
else ## а если открыть лог не можем, то
{ ## заявляем об этом на экран.
warn "Could not open logfile $logFileName";
}
exit; ## здесь заканчивается модуль main.
sub processDirectory ($$$$)
{
my ($indirname, $inext, $outdirname, $outext) = @_; ## считываем параметры
if (opendir (INDIR, $indirname)) ## если директория открывается, то
{
my @ls = readdir (INDIR); ## считываем список и закрываем
close (INDIR);
foreach my $infilename (sort @ls) ## теперь пробежимся по элементам списка
{
my $fullinfilename = "$indirname/$infilename"; ## установим полный путь к читаемому файлу
## если не директория и расширение совпадает, то
if ( (!(-d $fullinfilename)) && ($fullinfilename=~m/\.$inext$/si) )
{
my $fulloutfilename = "$outdirname/$infilename"; ## установим полный путь к файлу для записи
$inext eq $outext ## используя старое имя файла, а если расширения разные
|| $fulloutfilename =~ s/\.$inext$/\.$outext/si; ## то подставим расширение для нового файла
print 'Processing '.$fullinfilename."\n"; ## напечатаем на экран пути к обоим файлам
processFile($fullinfilename,$fulloutfilename); ## и обработаем файл
}
}
}
else ## если директория не открывается,
{ ## то скажем об этом
warn "Could not open input directory $indirname";
}
}
sub processFile ($$)
{
my ($infilename, $outfilename) = @_; ## считаем параметры вызова функции
my $fileBytesRead = 0; ## инициализируем переменные для
my $fileReplacementsMade = 0; ## сбора статистики по файлу
my $fileBytesWritten = 0;
my $fileBytesSaved = 0;
my $outfilebuf = ''; ## сбросим буфер вывода
if (open (INFILE, $infilename)) ## если филей открывается, то
{
print LOGFILE "\nInput file : $infilename\n"; ## напечатаем имя файла в журнал
# binmode (INFILE); ## перейдём в бинарный режим чтобы считать "как есть"
my $line; ## буфер для строки
my $message = ''; ## буфер для письма
while ($line = <INFILE>) ## читаем строку из файла
{
$fileBytesRead += length ($line); ## прибавляем кол-во прочитанных байт в список
if ( $line=~m/^From\s.*/ && $message ne '') ## если строка является началом мессаги
{ ## и буфер мессаги непустой то
$fileReplacementsMade += processMessage(\$message); ## обработаем мессагу регекспами,
$outfilebuf .= $message; ## запишем в буфер вывода,
$message = ''; ## и сбросим буфер мессаги
}
$message .= $line; ## припишем строку к буферу мессаги
}
close (INFILE); ## по окончании чтения закроем файл
print LOGFILE "Bytes read : $fileBytesRead\n"; ## запишем в журнал количество прочитанных байт
$global_totalBytesRead += $fileBytesRead; ## допишем количество прочитанных байт к статистике
if ($message ne '') ## если буфер мессаги содержит последнюю мессагу
{
$fileReplacementsMade += processMessage(\$message); ## обработаем последнюю мессагу
$outfilebuf .= $message; ## спишем её в буфер вывода,
$message = ''; ## и сбросим буфер мессаги
}
print LOGFILE "Replacements : $fileReplacementsMade\n"; ## запишем в журнал количество замен
$global_totalReplacements += $fileReplacementsMade; ## и прибавим к общей статистике
}
else ## если файл не открывается, то скажем об этом
{
warn 'Could not open input file '.$infilename;
}
if ($outfilebuf eq '' || not $fileReplacementsMade) ## если буфер вывода пустой и не было замен
{ ## запишем в журнал, что писать нечего
print LOGFILE 'Information : Nothing to write to '.$outfilename."\n";
} ## в противном случае, откроем файл на запись и
elsif (open (OUTFILE, ">$outfilename") ) ## если он успешно открылся, то
{
binmode OUTFILE; ## перейдём в бинарный режим чтобы избежать замены LF на CRLF
print OUTFILE $outfilebuf; ## печатаем буфер вывода в файл
close (OUTFILE); ## и закрываем файл
$fileBytesWritten += length ($outfilebuf); ## собираем статистику по количеству записанных
$fileBytesSaved = $fileBytesRead - $fileBytesWritten; ## байт и свободному месту
print LOGFILE "Output file : $outfilename\n"; ## и записываем имя файла и статистику в журнал
print LOGFILE "Bytes written : $fileBytesWritten\n";
print LOGFILE "Bytes saved : $fileBytesSaved\n";
$global_totalBytesWritten += $fileBytesWritten; ## и прибавляем статистику по файлу к глобальной статичтике
$global_totalBytesSaved += $fileBytesSaved;
print ' results are written to '.$outfilename."\n";
}
else ## если файл не открылся, то скажем об этом
{
warn 'Could not open output file '.$outfilename;
}
}
sub processMessage ($)
{
my $msgref = $_[0]; ## считываем ссылку на переменную с мессагой
my $matches = 0; ## устанавливаем переменную для подсчёта замен
if (${$msgref} =~ m/\A(.*?\n)\n(.*)\Z/sig) ## если мессага разбивается на заголовок и тело, то
{
my $header = $1; ## считываем заголовок и тело в переменные
my $body = $2;
## а теперь начинаем регекспить рекламу и прочий мусор из писем
## что-то From в начале UNIX-письма длинноват, заменим его на более короткий
$matches += ($header =~ s/\AFrom\s+[a-z0-9=_.-]+\@returns\.(?:groups\.yahoo|onelist)\.com/From egroups\@example\.com/sig);
## удаляем заголовки Received, Delivered-To, Return-Path, etc.
$matches += ($header =~ s/\n(?:Received|List-\w+|Delivered-To|User-Agent|Return-Path|Precedence|FL-Build):\s[^\n]+(\n\s+[^\n]+)*//sig);
## удаляем некоторые заголовки которые начинаются на X-, например все заголовки X-eGroups...
$matches += ($header =~ s/\n(?:X-(?:(?:eGroups|Yahoo)-[a-z0-9-]+|Sender|MSMail-Priority|Apparently-To|Originating-IP|MIME-Autoconverted|MimeOLE|Yahoo-Profile|RocketRCL|Real-To|Track|MDRemoteIP|Return-Path|MDaemon-Deliver-To|Clearance|Mailer-Plugin|Sieve|KOI8-Plugin-Info|WM-Posted-At)):\s[^\n]+(\n\s+[^\n]+)*//sig);
## удаляем префиксы Re[n]:,Fwd: и маркеры типа [st], [ft], [prox], [ctalk]
$matches += ($header =~ s/\nSubject:\x20*(?:(?:Re(?:\[\d+\]|):|Fwd:|\[(?:st|ft|pt|op|prox|CAB|ctalk)\])\x20*)+/\nSubject: /sig);
## удаляем адрес хозяина листа, всё равно его элементарно получить с сайта
$matches += ($header =~ s/(\nMailing-List: list [a-z0-9_-]+\@(?:egroups|yahoogroups)\.com); contact[^\n]+/$1/sig);
## (версия 2.2) агрессивная удалялка рекламы, даже отквоченную удаляет
$matches += ($body =~ s/\n+[^\n]{0,10}?-+ Yahoo! Groups Sponsor -+\~--\>\n.{20,400}?-+\~-\>//sig);
## удаляем рекламу групсов (теперь первый регексп не нужен, так как есть более агрессивный - см. выше)
# $matches += ($body =~ s/\n+------------------------ Yahoo! Groups Sponsor ---.*?-------------------------------------\~-\>//sig);
$matches += ($body =~ s/\n+Your use of (?:.){1,50}\/info\/terms\///sig);
## удаляем подписи некоторых листов, чтобы место не занимали
$matches += ($body =~ s/\n+\s+Unsubscribe:.{50,200}egroups\.com\/group\/privtalk//sig);
$matches += ($body =~ s/\n+To Post a message.{50,150}unsubscribe\@(?:yahoo|e)Groups\.com //sig);
$matches += ($body =~ s/\n+-- \nпФРЙУЛБ: ctalk-unsubscribe.{50,200}ctalk\/files\/faq\.txt//sig);
$matches += ($body =~ s/\n+-- \nUnsubscribe: any-topic-unsubscribe\@yahoogroups\.com//sig);
$matches += ($body =~ s/\n+-- \nпФРЙУЛБ: mailto:prox-ru-unsubscribe\@yahoogroups\.com\?body=_//sig);
## (версия 2.2) на эти листы я не подписан, но регексп прилагаю по просьбе трудящихся
# $matches += ($body =~ s/\n+To unsubscribe from this group, send an email to:\nsearch-ru-unsubscribe\@yahoogroups\.com//sig);
# $matches += ($body =~ s#\n+http://www\.windows\.sl\.ru\n\nTo unsubscribe send e-mail to\nwoerussia-unsubscribe\@yahoogroups\.com##sig);
## удаляем рекламу от модераторов (похоже что оная практика только набирает обороты)
$matches += ($body =~ s#\n+http://wincmd\.ru - чУЕ П Windows Commander #\n#sig);
$matches += ($body =~ s#\n+All about Windows Commander[^\n]+www\.wincommander\.by\.ru#\n#sig);
$matches += ($body =~ s,\n+жПТХН МАВЙФЕМЕК ЖХФВПМБ Ru-Football\nru-football-subscribe\@yahoogroups\.com ,\n,sig);
$matches += ($body =~ s#\n+http://directlinks\.ru - еЦЕДОЕЧОЩК ЦХТОБМ ДМС ЛПНРШАФЕТЭЙЛБ\. рТСНЩЕ УУЩМЛЙ ДМС УЛБЮЙЧБОЙС, УПЖФ, mp3, РТЙЛПМЩ Й НОПЗПЕ ДТХЗПЕ!\s+#\n#sig);
## удаляем рекламу сервисов типа яха или хотмайл
$matches += ($body =~ s#\n+_+\nDo You Yahoo!\?\n.{10,200}?\.yahoo\.com##sig);
## удаляем длинные подписи некоторых людей
$matches += ($body =~ s#\n+ _ _ _\n.*?/______/ \|___\| \|_\| \|___\| \|_/_\| \|_\|_\| \|_\|_\|##sig);
$matches += ($body =~ s#=-=-(?:=-)+=\nFrom:.{40,500}?(?:=-)+=##sig);
## удаляем лишние пробелы, а также пустые строки в конце
$matches += ($body =~ s/\n\s+\n/\n\n/sig);
$matches += ($body =~ s/([^\n])[\n]{3,}\Z/$1/sig);
## собираем части мессаги воедино и записываем в буфер мессаги обратно
${$msgref} = $header."\n".$body;
}
else ## если разбить нельзя, то просто предупреждаем
{ ## и ничего больше с ней не делаем
warn "Could not split the message into header and body";
}
return $matches; ## возвращаем количетво замен.
}
sub statsForThisRun() ## эта функция просто показывает статистику
{
return "\nStatistics for this run\n" ## остальное, я надеюсь, понятно ;-)
."Bytes read : $global_totalBytesRead\n"
."Replacements : $global_totalReplacements\n"
."Bytes written : $global_totalBytesWritten\n"
."Bytes saved : $global_totalBytesSaved\n";
}
|
