Why is the program loading the processor at 100%?

Question

Perl

There is a perl script daemon packaged with PerlApp into an exe and running on Windows Server 2008. Every 10 seconds it checks the folder for new images, resizes them, packs them into a ZIP archive and uploads them to the ftp server.
Whole code:

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: [email protected]");
      }
      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 ([email protected]) {
          write_log([email protected]);
        }
        
      }

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

  if ([email protected]) {
    write_log([email protected]);
  }


  # Пауза
  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;
}

The program worked well for several months, but now it began to load the processor at 100% immediately after launch. The working folder now does not contain files and, in fact, an almost empty sleep cycle is spinning. I connected the nytprof profiler and put exit at the end of the loop. PerlApp::my_require spends 9 seconds (I think it unpacks modules from exe and includes them) and another 10 seconds goes to sleep (I did not find any other significant time costs).
Out of interest, I created a file with the following content and launched it from exe:

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

CPU load in this case, as expected, is zero.
Then I looked at the process with the Process Explorer utility and found that it was hammering the registry several thousand times per second.

Why the program needed safe mode settings, I'll never know. Prompt, with what such strange behavior can be connected.

Answer 1

Virus attack?
No, seriously, somehow I managed without antivirus for about six months, then I installed it for some purpose. And then it started! Almost every executable was infected with the same shirus.

Answer 2

Yes, it looks like a virus.
Try to run this code without packaging in exe, just through perl interpreter.
Ideally, try to do this on a bare virtual machine with Windows. See what will happen.
It also makes sense to rebuild the exe file and compare it with the old uploader.exe.

Answer 3

Somewhere stuck. Maybe the sleep timeout in the config got lost and became zero, maybe for some reason the sleep is skipped or hangs in another cycle. Requests to the registry probably come from the functions of requesting information about the file (name, size). Maybe there are a lot of files in the folder and requests go without pauses at all (add a little sleep to the other two loops). I would add debug outputs and increase sleep for the duration of debugging

Answer 4

It is quite obvious that it is not the script itself that climbs into the registry - it does not have such an opportunity in principle, because. the module is not connected to work with the registry.
Hence the answer about "going in cycles" - nonsense.
But about the virus, the assumption is sound.
Ideally, get rid of packaging and Windows, but that's up to you.