Почему программа загружает процессор на 100%?

Question

[artem78]

Есть скрипт-демон на perl, упакованный с помощью PerlApp в exe и работающий на Windows Server 2008. Каждые 10 секунд он проверяет папку на наличие новых изображений, меняет их размер, упаковывает в ZIP-архив и загружает на ftp-сервер.

Код целиком:

spoiler

use strict;
use warnings;
#no warnings;

use encoding 'cp1251', STDOUT => 'cp1251';

#$\ = "\r\n";

use Net::FTP;
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
use LWP::Simple;
use Text::Trim;
use Image::Magick;
use Time::HiRes qw(gettimeofday);
use Image::Size;


use File::Basename;
my $dir_separator = '\\';
my $prog_dir = dirname($0) . $dir_separator;


my @image_types = qw(bmp jpg jpeg png); # Файлы с этими расширениями будут масштрабированы ImageMackik-ом

# Перенаправление вывода в файл
$| = 1;
open STDOUT, '>>', "$prog_dir${dir_separator}log.txt" or die "Ошибка перенаправления STDOUT: $!";
open STDERR, ">&STDOUT" or die "Ошибка перенаправления STDERR: $!";


# Чтение конфига
my %config;
open (my $fh, "<${prog_dir}config.cfg") or die("Ошибка чтения файла конфигурации: $!");
while (my $line = <$fh>) {
	if (my ($name, $val) = $line =~ /^(.*?)\s*=\s*"?([^#"]*)/) {
		$name = trim($name);
		$val = trim($val);
		$config{$name} = $val;
	}
}
close($fh);
$config{dev} = 0 unless defined $config{dev};


if ($config{'allowed_extensions'}) {
	$config{'allowed_extensions'} =~ tr/,/|/;
}



# Главный цикл
while (1) {
	eval {
		my @files;
		
		# Находим файлы для отправки
		print("\r\n");
		write_log("Сканирование папки") if $config{extra_log};
		opendir (my $dh, $config{local_dir}) or die "Ошибка чтения содержимого папки \"$config{local_dir}\": $!";
		while (my $filename = readdir($dh)) {
			my $file_path = $config{local_dir} . $dir_separator . $filename;
			next if -d $file_path;
			
			# Разрешена загрузка только заданных расширений
			unless (!$config{'allowed_extensions'} || $filename =~ /\.(${config{'allowed_extensions'}})$/i) {
				write_log("Пропускаем файл \"$filename\"") if $config{extra_log};
				next;
			}
			
			# Пропускаем файлы со скобками в имени
			if ($filename =~ /[\(\)]/) {
				write_log("Пропускаем файл \"$filename\" из-за скобок в названии") if $config{extra_log};
				next;
			}
			
			
			# Пропускаем файлы нулевого размера
			my @stats = stat($file_path);
			unless ($stats[7]) {
				write_log("Пропускаем пустой файл \"$filename\"") if $config{extra_log};
				next;
			}
			
			push(@files, $file_path);
		}
		closedir($dh);


		if (@files) {
			# Установка соединения с ФТП
			write_log("Подключение к FTP ...") if $config{extra_log};
			my $ftp = Net::FTP->new($config{ftp_host}, Debug => 0, Passive => 1, BlockSize => 1024 ** 2 * 5, Debug => ($config{ftp_log} ? 1 : 0));
			unless ($ftp) {
				die("Ошибка подключения к ftp: $@");
			}
			unless ($ftp->login($config{ftp_user}, $config{ftp_pass})) {
				die('Ошибка авторизации: ' . $ftp->message);
			}
			$ftp->binary;

			unless ($ftp->cwd($config{ftp_dir})) {
				die("Ошибка смены директории ftp: " . $ftp->message);
			}
			write_log("Ok") if $config{extra_log};

			
			foreach my $file_path (@files) {
				eval {
					my($file_name, $dir, $suffix) = fileparse($file_path);
					write_log("Начинаем обработку файла \"$file_name\"");
					my($file_name1, $ext) = $file_name =~ /^(.*?)\.([^.]+)$/;
					$ext = lc($ext);
					my $zip_file_name = "$file_name1.zip";
					my $zip_path = "$config{temp_dir}$dir_separator$zip_file_name";
					
					
					# Увеличиваем изображение в два раза
					if ($ext ~~ @image_types) {
						# Определяем размер изображения
						write_log('Определяем размер изображения ...');
						my ($w, $h) = imgsize($file_path);
						my $s = $w * $h;
						write_log('Ok');
						write_log("Текущий размер: ${w}x$h");
						write_log("Пикселей: " . format_num($s));
						if ($s && $s < 15_000_000) { # Делаем ресайз только если изображение меньше
							write_log('Чтение изображения ...');
							my $img = new Image::Magick;
							my $r = $img->Read($file_path);
							unless ($r) {
								write_log('Ok');
								my ($w2, $h2) = ($w * 2, $h * 2); # Новый размер
								write_log("Изменение размера до ${w2}x${h2} ...");
								$r = $img->Resize(width => $w2, height => $h2, filter => 'Lanczos');
								unless ($r) {
									$r = $img->Write($file_path);
									unless ($r) {
										write_log("Ok");
									} else {
										write_log("Ошибка записи: $r");
									}
								} else {
									write_log("Ошибка масштабирования: $r");
								}
							} else {
								write_log("Ошибка чтения: $r");
							}
							undef($img);
						} else {
							write_log('Ресайз не нужен');
						}
					}
					
					
					
					# Упаковываем в zip
					write_log("Создание архива \"$zip_file_name\" ...") if $config{extra_log};
					my $zip = new Archive::Zip;
					$zip->addFile($file_path, $file_name);
					unless (my $code = $zip->writeToFileNamed($zip_path) == AZ_OK ) {
						write_log("Ошибка упаковки файла \"$file_name\" в архив. Код ошибки: $code.");
					} else {
						write_log("Ok") if $config{extra_log};
						
						# Загружаем файл на FTP
						write_log("Начинаем загрузку файла \"$zip_file_name\" ...") if $config{extra_log};
						my $upload_success = 0;
						if ($ftp->put($zip_path)) {							
							unlink($file_path);
							
							# Отправка GET-запроса
							if (!$config{dev}) {
								my ($file_no) = $file_name1 =~ /(\d+)$/;
								unless (defined(get("http://xxxxxxxxxx?id=$file_no"))) {
									write_log("Ошибка отправки GET-запроса");
								}
							}
							
							write_log("Загружен файл \"$zip_file_name\"");
						} else {
							write_log("Ошибка при загрузке файла \"$zip_file_name\": " . $ftp->message);
						}
					
						unlink($zip_path);
					}
					
					undef($zip);
				};
				
				if ($@) {
					write_log($@);
				}
				
			}

			# Завершение соединения
			$ftp->quit;
			undef($ftp);
		} else {
			#print "Нечего загружать";
		}
	};

	if ($@) {
		write_log($@);
	}


	# Пауза
	sleep $config{interval};
}


sub write_log {
	my ($str) = @_;
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
	$mon++;
	$year += 1900;
	my (undef, $usec) = gettimeofday;
	printf("[%02d.%02d.%04d %02d:%02d:%02d.%03d]\t%s\r\n", $mday, $mon, $year, $hour, $min, $sec, $usec / 1000, $str);
}

sub format_num {
	my $num = shift;
	$num =~ s/(?<=\d)(?=(\d{3})+(?!\d))/ /g;
	return $num;
}

Программа работала хорошо в течении нескольких месяцев, но теперь стала грузить процессор на 100% сразу после запуска. Рабочая папка сейчас не содержит файлов и по-сути крутится почти пустой цикл со sleep-ом. Подключил профайлер nytprof и поставил exit в конце цикла. PerlApp::my_require тратит 9 секунд (я так думаю, он распаковывает модули из exe и подключает их) и ещё 10 секунд уходит на sleep (больше никаких существенных затрат времени я не обнаружил).

Из интереса создал файл со следующим содержимым и запустил из exe:

$n = 1;
while (1) {
	print $n++ . "\n";
	sleep(1);
}

Загрузка процессора в этом случае как и ожидалось нулевая.

Затем посмотрел процесс утилитой Process Explorer и обнаружил что он долбит реестр по несколько тысяч раз в секунду.



Зачем программе понадобились настройки безопасного режима, ума не приложу. Подскажите, с чем может быть связано такое странное поведение.

Answer 1

[Otrivin]

Вирусная атака?
Нет, серьезно, как-то я около полугода обходился без антивиря, потом для каких-то целей установил. И тут понеслось! Почти каждый экзешник оказался заражен одним и тем же присоседившимся ширусом.

Comments

[artem78]

Похоже вы правы. На машине антивирус не установлен. Загрузил exe в VirusTotal - показатель выявления 50 из 61. Детектируется некий Win32.Sality/Win32.Sector.

Результат сканирования

Answer 2

[pcdesign]

Да, похоже на вирус.
Попробуйте запускать этот код без упаковки в exe, просто через perl-интерпретатор.

В идеале еще на голой виртуалке c виндной попробовать это сделать. Посмотреть что будет.

Так же имеет смысл собрать exe-файл по новой и сравнить его со старым uploader.exe.

Answer 3

[15432]

Где-то зациклилось. Может таймаут слипа в конфиге сбился и стал нулевым, может по какому-то условию слип пропускается или в другом цикле виснет. Запросы к реестру, вероятно, идут от функций запроса информации о файле (имя, размер). Может в папке очень много файлов и запросы идут вообще без пауз (добавьте небольшой sleep в два других цикла). Я б добавил отладочные выводы и увеличил sleep на время отладки

Comments

[artem78]

Где-то зациклилось.

Не думаю, так как в логе записи идут строго с интервалом в 10 секунд.

Может в папке очень много файлов

Нет, как писал в вопросе даже если папка пуста, всё равно грузит.

Answer 4

[parserpro]

Вполне очевидно что в реестр лезет не сам скрипт - у него нет такой возможности в принципе, т.к. модуль не подключен для работы с реестром.
Отсюда ответ про "зациклилось" - бред.
А вот про вирус предположение здравое.
В идеале - избавиться от упаковки и Windows, но это уже вам решать.