537 lines
15 KiB
Perl
537 lines
15 KiB
Perl
|
#!/usr/bin/perl
|
||
|
|
#
|
||
|
|
# <LJDEP>
|
||
|
|
# lib: MIME::Parser, Mail::Address, cgi-bin/ljlib.pl, cgi-bin/supportlib.pl
|
||
|
|
# </LJDEP>
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use lib "$ENV{LJHOME}/cgi-bin";
|
||
|
|
use Getopt::Long;
|
||
|
|
use Sys::Hostname;
|
||
|
|
use MIME::Parser;
|
||
|
|
use Mail::Address;
|
||
|
|
use Proc::ProcessTable;
|
||
|
|
use Unicode::MapUTF8 ();
|
||
|
|
use File::Temp ();
|
||
|
|
use File::Path ();
|
||
|
|
use Danga::Daemon;
|
||
|
|
|
||
|
|
require "$ENV{LJHOME}/cgi-bin/ljconfig.pl";
|
||
|
|
|
||
|
|
# worker globals
|
||
|
|
use vars qw/ $mailspool $mailspool_new $workdir $maxloop
|
||
|
|
$hostname $locktype $opt /;
|
||
|
|
$opt = {};
|
||
|
|
Getopt::Long::GetOptions $opt, qw/ workdir=s lock=s maxloop=s /;
|
||
|
|
|
||
|
|
# mailspool should match the MTA delivery location.
|
||
|
|
$mailspool = $LJ::MAILSPOOL || "$ENV{'LJHOME'}/mail";
|
||
|
|
$mailspool_new = "$mailspool/new";
|
||
|
|
|
||
|
|
# setup defaults
|
||
|
|
$hostname = $1 if Sys::Hostname::hostname() =~ /^([\w-]+)/;
|
||
|
|
$locktype = $opt->{'lock'} || $LJ::MAILLOCK;
|
||
|
|
die "Invalid lock mechanism specified. Set \$LJ::MAILLOCK or use --lock.\n"
|
||
|
|
unless $locktype =~ /hostname|none|ddlockd/i;
|
||
|
|
$workdir = $opt->{'workdir'} || "$mailspool/tmp";
|
||
|
|
$maxloop = $opt->{'maxloop'} || 100;
|
||
|
|
|
||
|
|
# sanity checks
|
||
|
|
die "Invalid mailspool: $mailspool\n" unless -d $mailspool_new;
|
||
|
|
die "Unable to read mailspool: $mailspool\n" unless -r $mailspool;
|
||
|
|
|
||
|
|
Danga::Daemon::daemonize(
|
||
|
|
|
||
|
|
\&worker,
|
||
|
|
{
|
||
|
|
interval => 10,
|
||
|
|
shedprivs => 'lj',
|
||
|
|
|
||
|
|
listenport => 15000,
|
||
|
|
listencode => \&cmd_interface,
|
||
|
|
}
|
||
|
|
|
||
|
|
);
|
||
|
|
|
||
|
|
# main event loop for mailgated.
|
||
|
|
# examine mailspool, populate queues, and call
|
||
|
|
# process() as needed.
|
||
|
|
sub worker
|
||
|
|
{
|
||
|
|
require "$ENV{'LJHOME'}/cgi-bin/ljemailgateway.pl";
|
||
|
|
require "$ENV{'LJHOME'}/cgi-bin/supportlib.pl";
|
||
|
|
require "$ENV{'LJHOME'}/cgi-bin/ljlib.pl";
|
||
|
|
require "$ENV{'LJHOME'}/cgi-bin/sysban.pl";
|
||
|
|
$| = 1;
|
||
|
|
|
||
|
|
debug("Starting loop:");
|
||
|
|
cleanup();
|
||
|
|
LJ::start_request();
|
||
|
|
|
||
|
|
# Get list of files to process.
|
||
|
|
# If a file simply exists in the mailspool, it needs attention.
|
||
|
|
debug("\tprocess");
|
||
|
|
opendir( MDIR, $mailspool_new )
|
||
|
|
|| die "Unable to open mailspool $mailspool_new: $!\n";
|
||
|
|
my @all_files = readdir(MDIR);
|
||
|
|
closedir MDIR;
|
||
|
|
|
||
|
|
# Separate new messages from retries.
|
||
|
|
# Hostname as part of the filename is Maildir specification -
|
||
|
|
# use 'hostname' locking to be safe across NFS.
|
||
|
|
my ( @new_messages, @retry_messages );
|
||
|
|
foreach (@all_files) {
|
||
|
|
next if /^\./;
|
||
|
|
next if $locktype eq 'hostname' && !/\.$hostname\b/;
|
||
|
|
if ( get_pcount($_) == 0 ) { # new message
|
||
|
|
push @new_messages, $_;
|
||
|
|
}
|
||
|
|
else { # message retry
|
||
|
|
push @retry_messages, $_;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Make sure at least half of our processesing
|
||
|
|
# queue is made up of new messages.
|
||
|
|
# Randomize, so if we're running multiple mailgated
|
||
|
|
# processess, they'll be more likely to be working on
|
||
|
|
# different messages.
|
||
|
|
rand_array( \@retry_messages, int( $maxloop / 2 ) ); # half queue max
|
||
|
|
# fill the rest of the queue with new messages.
|
||
|
|
rand_array( \@new_messages, $maxloop - ( scalar @retry_messages ) );
|
||
|
|
|
||
|
|
# do the work
|
||
|
|
foreach my $file ( @new_messages, @retry_messages ) {
|
||
|
|
my $lock;
|
||
|
|
if ( get_pcount($file) % 20 == 0 ) { # only retry every 20th iteration
|
||
|
|
if ( lc($locktype) eq 'ddlockd' ) {
|
||
|
|
$lock = LJ::locker()->trylock("mailgated-$file");
|
||
|
|
next unless $lock;
|
||
|
|
}
|
||
|
|
eval { process($file); };
|
||
|
|
if ($@) {
|
||
|
|
debug("\t\t$@");
|
||
|
|
set_pcount($file);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
set_pcount($file);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
debug("\tdone\n");
|
||
|
|
LJ::end_request();
|
||
|
|
}
|
||
|
|
|
||
|
|
# additional command line options
|
||
|
|
sub cmd_interface
|
||
|
|
{
|
||
|
|
my ( $line, $s, $c, $codeloop, $codeopts ) = @_;
|
||
|
|
|
||
|
|
if ($line =~ /help/i) {
|
||
|
|
foreach (sort qw/ ping pids reload stop queuesize status /) {
|
||
|
|
print $c "\t$_\n";
|
||
|
|
}
|
||
|
|
print $c ".\nOK\n";
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($line =~ /queuesize/) {
|
||
|
|
if (! opendir(MDIR, $mailspool_new)) {
|
||
|
|
print $c "Unable to open mailspool $mailspool_new: $!\n";
|
||
|
|
} else {
|
||
|
|
my $count = 0;
|
||
|
|
foreach (readdir(MDIR)) {
|
||
|
|
next if /^\./;
|
||
|
|
$count++;
|
||
|
|
}
|
||
|
|
closedir MDIR;
|
||
|
|
print $c "$count\n";
|
||
|
|
}
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($line =~ /status/) {
|
||
|
|
my $pid = $Danga::Daemon::pid;
|
||
|
|
my $t = new Proc::ProcessTable;
|
||
|
|
my $state;
|
||
|
|
|
||
|
|
foreach my $p ( @{$t->table} ){
|
||
|
|
$state = $p->state if $p->pid == $pid;
|
||
|
|
}
|
||
|
|
|
||
|
|
print $c "mailgate ";
|
||
|
|
print $c ($state ne 'defunct' && kill 0, $pid) ? "running" : "down";
|
||
|
|
print $c "\n";
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Remove prior run workdirs.
|
||
|
|
# File::Temp's CLEANUP only works upon program exit.
|
||
|
|
sub cleanup
|
||
|
|
{
|
||
|
|
debug("\tcleanup");
|
||
|
|
my $now = time();
|
||
|
|
unless ( opendir( TMP, $workdir ) ) {
|
||
|
|
debug("\t\tCan't open workdir $workdir: $!");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
my $limit = 0;
|
||
|
|
foreach ( readdir(TMP) ) {
|
||
|
|
next unless /^ljmailgate_/;
|
||
|
|
last if $limit >= 50;
|
||
|
|
$limit++;
|
||
|
|
my $modtime = ( stat("$workdir/$_") )[9];
|
||
|
|
if ( $now - $modtime > 300 ) {
|
||
|
|
File::Path::rmtree("$workdir/$_");
|
||
|
|
debug("\t\t$workdir/$_");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
closedir TMP;
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
# takes an array ref - truncates to max size and shuffles it.
|
||
|
|
sub rand_array
|
||
|
|
{
|
||
|
|
my ( $array, $max ) = @_;
|
||
|
|
|
||
|
|
my ( @tmp, $c );
|
||
|
|
while (@$array) {
|
||
|
|
push( @tmp, splice( @$array, rand(@$array), 1 ) );
|
||
|
|
last if ++$c == $max;
|
||
|
|
}
|
||
|
|
@$array = @tmp;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub set_pcount
|
||
|
|
{
|
||
|
|
my ( $file, $resetattempt ) = @_;
|
||
|
|
my $attempt = get_pcount($file);
|
||
|
|
$attempt++;
|
||
|
|
$attempt = 0 if $resetattempt;
|
||
|
|
|
||
|
|
my $name = $file;
|
||
|
|
$name =~ s/:\d+$//;
|
||
|
|
$name = $name . ":" . $attempt;
|
||
|
|
rename "$mailspool_new/$file", "$mailspool_new/$name";
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
# return the number of times we've seen this
|
||
|
|
# message in the queue
|
||
|
|
sub get_pcount
|
||
|
|
{
|
||
|
|
return 0 unless shift() =~ /:(\d+)$/;
|
||
|
|
return $1;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Either an unrecoverable error, or a total success. ;)
|
||
|
|
# Regardless, we're done with this message.
|
||
|
|
# Remove it so it isn't processed again.
|
||
|
|
our $last_file;
|
||
|
|
our $last_tempdir;
|
||
|
|
|
||
|
|
sub dequeue
|
||
|
|
{
|
||
|
|
my $msg = shift;
|
||
|
|
debug("\t\t dequeued: $msg") if $msg;
|
||
|
|
unlink("$mailspool_new/$last_file")
|
||
|
|
|| debug("\t\t Can't unlink $last_file!");
|
||
|
|
File::Path::rmtree($last_tempdir);
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
# cleanup mime tempdirs, update attempt number,
|
||
|
|
# but don't delete the message.
|
||
|
|
sub retry
|
||
|
|
{
|
||
|
|
my $msg = shift;
|
||
|
|
debug("\t\t retrying: $msg") if $msg;
|
||
|
|
set_pcount($last_file);
|
||
|
|
File::Path::rmtree($last_tempdir);
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
# examine message contents and decide what to do
|
||
|
|
# with it.
|
||
|
|
sub process
|
||
|
|
{
|
||
|
|
my $file = shift;
|
||
|
|
debug("\t\t$file");
|
||
|
|
my $tmpdir =
|
||
|
|
File::Temp::tempdir( "ljmailgate_" . 'X' x 20, DIR => $workdir );
|
||
|
|
my $parser = new MIME::Parser;
|
||
|
|
|
||
|
|
# for dequeue sub:
|
||
|
|
$last_file = $file;
|
||
|
|
$last_tempdir = $tmpdir;
|
||
|
|
|
||
|
|
$parser->output_dir($tmpdir);
|
||
|
|
|
||
|
|
# Close the message as quickly as possible, in case
|
||
|
|
# we need to change status mid process.
|
||
|
|
open( MESSAGE, "$mailspool_new/$file" )
|
||
|
|
|| debug("\t\t Can't open file: $!") && return;
|
||
|
|
my $entity;
|
||
|
|
eval { $entity = $parser->parse( \*MESSAGE ) };
|
||
|
|
close MESSAGE;
|
||
|
|
return dequeue("Can't parse MIME") if $@;
|
||
|
|
|
||
|
|
my $head = $entity->head;
|
||
|
|
$head->unfold;
|
||
|
|
|
||
|
|
my $subject = $head->get('Subject');
|
||
|
|
chomp $subject;
|
||
|
|
|
||
|
|
# ignore spam/vacation/auto-reply messages
|
||
|
|
if ( $subject =~ /auto.?(response|reply)/i
|
||
|
|
|| $subject =~
|
||
|
|
/^(Undelive|Mail System Error - |ScanMail Message: |\+\s*SPAM|Norton AntiVirus)/i
|
||
|
|
|| $subject =~ /^(Mail Delivery Problem|Mail delivery failed)/i
|
||
|
|
|| $subject =~ /^failure notice$/i
|
||
|
|
|| $subject =~ /\[BOUNCED SPAM\]/i
|
||
|
|
|| $subject =~ /^Symantec AVF /i
|
||
|
|
|| $subject =~ /Attachment block message/i
|
||
|
|
|| $subject =~ /Use this patch immediately/i
|
||
|
|
|| $subject =~ /^YOUR PAYPAL\.COM ACCOUNT EXPIRES/i
|
||
|
|
|| $subject =~ /^don\'t be late! ([\w\-]{1,15})$/i
|
||
|
|
|| $subject =~ /^your account ([\w\-]{1,15})$/i )
|
||
|
|
{
|
||
|
|
return dequeue("Spam");
|
||
|
|
}
|
||
|
|
|
||
|
|
# quick and dirty (and effective) scan for viruses
|
||
|
|
return dequeue("Virus found") if virus_check($entity);
|
||
|
|
|
||
|
|
# see if it's a post-by-email
|
||
|
|
my @to = Mail::Address->parse( $head->get('To') );
|
||
|
|
if ( scalar @to > 0 ) {
|
||
|
|
foreach my $dest ( @to ) {
|
||
|
|
next unless $dest->address =~ /^(\S+?)\@\Q$LJ::EMAIL_POST_DOMAIN\E$/i;
|
||
|
|
|
||
|
|
my $user = $1;
|
||
|
|
|
||
|
|
# FIXME: verify auth (extra from $user/$subject/$body), require ljprotocol.pl, do post.
|
||
|
|
# unresolved: where to temporarily store messages before they're approved?
|
||
|
|
# perhaps the modblob table? perhaps a column it can be used to determine
|
||
|
|
# whether it's a moderated community post vs. an un-acked phone post.
|
||
|
|
my $post_rv;
|
||
|
|
my $post_msg = LJ::Emailpost::process( $entity, $user, \$post_rv );
|
||
|
|
|
||
|
|
return $post_rv ? dequeue($post_msg) : retry($post_msg);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# stop more spam, based on body text checks
|
||
|
|
my $tent = LJ::Emailpost::get_entity($entity);
|
||
|
|
$tent = LJ::Emailpost::get_entity( $entity, 'html' ) unless $tent;
|
||
|
|
return dequeue("Can't find text or html entity") unless $tent;
|
||
|
|
my $body = $tent->bodyhandle->as_string;
|
||
|
|
$body = LJ::trim($body);
|
||
|
|
|
||
|
|
### spam
|
||
|
|
if ( $body =~ /I send you this file in order to have your advice/i
|
||
|
|
|| $body =~ /^Content-Type: application\/octet-stream/i
|
||
|
|
|| $body =~ /^(Please see|See) the attached file for details\.?$/i )
|
||
|
|
{
|
||
|
|
return dequeue("Spam");
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# From this point on we know it's a support request of some type,
|
||
|
|
my $email2cat = LJ::Support::load_email_to_cat_map();
|
||
|
|
|
||
|
|
my $to;
|
||
|
|
my $toarg;
|
||
|
|
my $ignore = 0;
|
||
|
|
foreach my $a ( @to, Mail::Address->parse( $head->get('Cc') ) ) {
|
||
|
|
my $address = $a->address;
|
||
|
|
my $arg;
|
||
|
|
if ( $address =~ /^(.+)\+(.*)\@(.+)$/ ) {
|
||
|
|
( $address, $arg ) = ( "$1\@$3", $2 );
|
||
|
|
}
|
||
|
|
if ( defined $LJ::ALIAS_TO_SUPPORTCAT{$address} ) {
|
||
|
|
$address = $LJ::ALIAS_TO_SUPPORTCAT{$address};
|
||
|
|
}
|
||
|
|
if ( defined $email2cat->{$address} ) {
|
||
|
|
$to = $address;
|
||
|
|
$toarg = $arg;
|
||
|
|
}
|
||
|
|
$ignore = 1 if $address eq $LJ::IGNORE_EMAIL;
|
||
|
|
$ignore = 1 if $address eq $LJ::BOGUS_EMAIL;
|
||
|
|
}
|
||
|
|
|
||
|
|
return dequeue("Not deliverable to support system (no match To:)")
|
||
|
|
unless $to;
|
||
|
|
|
||
|
|
my $adf = ( Mail::Address->parse( $head->get('From') ) )[0];
|
||
|
|
return dequeue("Bogus From: header") unless $adf;
|
||
|
|
|
||
|
|
my $name = $adf->name;
|
||
|
|
my $from = $adf->address;
|
||
|
|
$subject ||= "(No Subject)";
|
||
|
|
|
||
|
|
# is this a reply to another post?
|
||
|
|
if ( $toarg =~ /^(\d+)z(.+)$/ ) {
|
||
|
|
my $spid = $1;
|
||
|
|
my $miniauth = $2;
|
||
|
|
my $sp = LJ::Support::load_request($spid);
|
||
|
|
|
||
|
|
LJ::Support::mini_auth($sp) eq $miniauth
|
||
|
|
or die "Invalid authentication?";
|
||
|
|
|
||
|
|
if ( LJ::sysban_check( 'support_email', $from ) ) {
|
||
|
|
my $msg = "Support request blocked based on email.";
|
||
|
|
LJ::sysban_block( 0, $msg, { 'email' => $from } );
|
||
|
|
return dequeue($msg);
|
||
|
|
}
|
||
|
|
|
||
|
|
# make sure it's not locked
|
||
|
|
return dequeue("Request is locked, can't append comment.")
|
||
|
|
if LJ::Support::is_locked($sp);
|
||
|
|
|
||
|
|
# valid. need to strip out stuff now with authcodes:
|
||
|
|
$body =~ s!http://.+/support/act\.bml\S+![snipped]!g;
|
||
|
|
$body =~ s!\+(\d)+z\w{1,10}\@!\@!g;
|
||
|
|
$body =~ s!&auth=\S+!!g;
|
||
|
|
|
||
|
|
## try to get rid of reply stuff.
|
||
|
|
# Outlook Express:
|
||
|
|
$body =~ s!(\S+.*?)-{4,10} Original Message -{4,10}.+!$1!s;
|
||
|
|
|
||
|
|
# Pine/Netscape
|
||
|
|
$body =~ s!(\S+.*?)\bOn [^\n]+ wrote:\n.+!$1!s;
|
||
|
|
|
||
|
|
# append the comment, re-open the request if necessary
|
||
|
|
my $splid = LJ::Support::append_request(
|
||
|
|
$sp,
|
||
|
|
{
|
||
|
|
'type' => 'comment',
|
||
|
|
'body' => $body,
|
||
|
|
}
|
||
|
|
)
|
||
|
|
or return dequeue("Error appending request?");
|
||
|
|
|
||
|
|
LJ::Support::touch_request($spid);
|
||
|
|
|
||
|
|
return dequeue("Support reply success");
|
||
|
|
}
|
||
|
|
|
||
|
|
# Now see if we want to ignore this particular email and bounce it back with
|
||
|
|
# the contents from a file. Check $LJ::DENY_REQUEST_FROM_EMAIL first. Note
|
||
|
|
# that this will only bounce initial emails; if a user replies to an email
|
||
|
|
# from a request that's open, it'll be accepted above.
|
||
|
|
my ( $content_file, $content );
|
||
|
|
if ( %LJ::DENY_REQUEST_FROM_EMAIL && $LJ::DENY_REQUEST_FROM_EMAIL{$to} ) {
|
||
|
|
$content_file = $LJ::DENY_REQUEST_FROM_EMAIL{$to};
|
||
|
|
$content = LJ::load_include($content_file);
|
||
|
|
}
|
||
|
|
if ( $content_file && $content ) {
|
||
|
|
|
||
|
|
# construct mail to send to user
|
||
|
|
my $email = <<EMAIL_END;
|
||
|
|
$content
|
||
|
|
|
||
|
|
Your original message:
|
||
|
|
|
||
|
|
$body
|
||
|
|
EMAIL_END
|
||
|
|
|
||
|
|
# send the message
|
||
|
|
LJ::send_mail(
|
||
|
|
{
|
||
|
|
'to' => $from,
|
||
|
|
'from' => $LJ::BOGUS_EMAIL,
|
||
|
|
'subject' => "Your Email to $to",
|
||
|
|
'body' => $email,
|
||
|
|
'wrap' => 1,
|
||
|
|
}
|
||
|
|
);
|
||
|
|
|
||
|
|
# all done
|
||
|
|
return dequeue("Support request bounced to origin");
|
||
|
|
}
|
||
|
|
|
||
|
|
# make a new post.
|
||
|
|
my @errors;
|
||
|
|
|
||
|
|
# convert email body to utf-8
|
||
|
|
my $content_type = $head->get('Content-type:');
|
||
|
|
my $charset = $1
|
||
|
|
if $content_type =~ /\bcharset=[\'\"]?(\S+?)[\'\"]?[\s\;]/i;
|
||
|
|
if ( defined($charset)
|
||
|
|
&& $charset !~ /^UTF-?8$/i
|
||
|
|
&& Unicode::MapUTF8::utf8_supported_charset($charset) )
|
||
|
|
{
|
||
|
|
$body =
|
||
|
|
Unicode::MapUTF8::to_utf8(
|
||
|
|
{ -string => $body, -charset => $charset } );
|
||
|
|
}
|
||
|
|
|
||
|
|
my $spid = LJ::Support::file_request(
|
||
|
|
\@errors,
|
||
|
|
{
|
||
|
|
'spcatid' => $email2cat->{$to}->{'spcatid'},
|
||
|
|
'subject' => $subject,
|
||
|
|
'reqtype' => 'email',
|
||
|
|
'reqname' => $name,
|
||
|
|
'reqemail' => $from,
|
||
|
|
'body' => $body,
|
||
|
|
}
|
||
|
|
);
|
||
|
|
|
||
|
|
if (@errors) {
|
||
|
|
# FIXME: detect trasient vs. permanent errors (changes to
|
||
|
|
# file_request above, probably) and either dequeue or try
|
||
|
|
# later
|
||
|
|
return dequeue("Support errors: @errors");
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return dequeue("Support request success");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# returns true on found virus
|
||
|
|
sub virus_check
|
||
|
|
{
|
||
|
|
my $entity = shift;
|
||
|
|
return unless $entity;
|
||
|
|
|
||
|
|
my @exe = LJ::Emailpost::get_entity( $entity, 'all' );
|
||
|
|
return unless scalar @exe;
|
||
|
|
|
||
|
|
# If an attachment's encoding begins with one of these strings,
|
||
|
|
# we want to completely drop the message.
|
||
|
|
# (Other 'clean' attachments are silently ignored, and the
|
||
|
|
# message is allowed.)
|
||
|
|
my @virus_sigs =
|
||
|
|
qw(
|
||
|
|
TVqQAAMAA TVpQAAIAA TVpAALQAc TVpyAXkAX TVrmAU4AA
|
||
|
|
TVrhARwAk TVoFAQUAA TVoAAAQAA TVoIARMAA TVouARsAA
|
||
|
|
TVrQAT8AA UEsDBBQAA UEsDBAoAAA
|
||
|
|
R0lGODlhaAA7APcAAP///+rp6puSp6GZrDUjUUc6Zn53mFJMdbGvvVtXh2xre8bF1x8cU4yLprOy
|
||
|
|
);
|
||
|
|
|
||
|
|
# get the length of the longest virus signature
|
||
|
|
my $maxlength =
|
||
|
|
length( ( sort { length $b <=> length $a } @virus_sigs )[0] );
|
||
|
|
$maxlength = 1024 if $maxlength >= 1024; # capped at 1k
|
||
|
|
|
||
|
|
foreach my $part (@exe) {
|
||
|
|
my $contents = $part->stringify_body;
|
||
|
|
$contents = substr $contents, 0, $maxlength;
|
||
|
|
|
||
|
|
foreach (@virus_sigs) {
|
||
|
|
return 1 if index( $contents, $_ ) == 0;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|